perm filename SUPG03.PAS[S1,ALS] blob
sn#487232 filedate 1979-10-04 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00075 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00013 00002 (*PROGRAM HEADER PAGE*)
C00016 00003 (*%IFT D10*)
C00018 00004 (* Compiler-option constants... *)
C00027 00005 (* Constants fixed by S1 architecture... *)
C00034 00006 type
C00068 00007 var
C00081 00008 (** ERROR_CLASS: ERREXIT ASSERTFAIL ERROR **)
C00102 00009 (** DEBUGGING_CLASS: PRINTSET PRINTMEMOREG PRINTDATUM PRINT_NESTITEM PRINT_MSTENTRY PRINTNXTINST PRINTNAM PRINTTYP PRINTMTYP PRINTINT **)
C00117 00010 (** SETREP_PROCESSOR_CLASS: SET_IN SET_DIF SET_INT SET_UNI BUILD_SET *)(*setch*)
C00122 00011 (** S1WORD_PROCESSOR_CLASS: NEWCODEREC MAKE_NEWINSTREC NEWOPNDXWORDREC NEWOPND2REC GETFIELD GETSIGNEDFIELD PUTFIELD **)
C00132 00012 (** S1WORD_PROCESSOR_CLASS: REAL_TO_S1WORD ZSYMBOL_TO_S1WORDS INTEGER_TO_S1WORD SETREP_TO_S1WORDS **)
C00143 00013 (** MISCELLANEOUS_CLASS: LABELHASH LABELNUMBER MIN MAX POWER2 FLDW CVCHR_S1WORD_4 CVOS_S1WORD_12 CVOS_12 CVOS_10 CSP_HASH OPC_HASH NAME_TO_CSP MNEM_TO_OPC **)
C00151 00014 (** INSTRUCTION_PROCESSOR_CLASS: S1OPNDS_EQUAL S1OPND_TEMPLOC AFTER_FAKEOPS AFTER_NONS1LOC_FAKEOPS INVERT_OPCODE **)
C00158 00015 (** INSTRUCTION_PROCESSOR_CLASS: DELETE_INSTR INSERT_OPND1 PEEP_LOC_IS_FREE SWAP_OPERANDS INSTR_WORDS PRINTMAINCODE **)
C00167 00016 (** FIXUP_CLASS: FIXSOP FIXJOP FIXOPND2 ADD_XWPTR_TO_OPNDXWFIXLIST**)
C00172 00017 (** FIXUP_CLASS: ADD_INSTPTR_TO_OPND2FIXLIST AP_JUMPLIST_PLUS_ONE AP_JUMP_TO_JUMPLIST JMP_TO_TABLE_RECORD_OR_FIX JUMP_TO_LABEL_RECORD_OR_FIX OPND2_RECORD_OR_FIX **)
C00178 00018 (** OPERAND_PROCESSOR_CLASS: ISREG IS_T_REG IS_T_RG_NOT_RT ISSHORTCONST ISCONST EQUAL_OPERANDS REG_OPERAND IMM_OPERAND REAL_IMM_OPERAND IS_RT IS_RTA IS_RTB USES_RTA USES_RTB **)
C00186 00019 (** OPERAND_PROCESSOR_CLASS: XTNDED_IMM_OPERAND REGDISP_OPERAND XTNDED_REGDISP_OPERAND EXT_REGADDR_OPERAND ADDR_OPERAND TWIDDLE_OPERAND **)
C00193 00020 (** REGISTER/GLOBAL_MANAGEMENT_CLASS: ALLOCGBL FREEGBL_S ALLAREFREE ALLOCRG ALLOCRP FREERG_S FINDRGBLOCK FINDRP FINDRG MOVE_AND_FREE_RTB CURRENT_PARMREG_COUNT IS_PARMREG CHECK_DSP_TMP_COLLISION RESERVE_PARMREGS **)
C00206 00021 (** REGISTER/GLOBAL_MANAGEMENT_CLASS: FREEDATUMREGS FREEREGSBUTONE FREERGSBUTSOME FREEVPAREG FREVPARGUNLESS FREE_TEMP_REGS **)
C00214 00022 (** FORM_CODE CLASS: FORM_CW_OPERAND FORMFAKEINST FORMSOP FORMJOP FORMTOP FORMXOP
C00221 00023 (** CODE_EMITTER_CLASS: CONNECT_TO_FIXUP_LIST EMIT_INSTR_OPNDS INSERT_INSTR_OPNDS **)
C00228 00024 (** CODE_EMITTER_CLASS: EMITFAKEOP INSERTSOP INSERTJOP INSERTXOP EMIT_S1WORD EMIT_ZEROS1WORD **)
C00235 00025 (** CODE_EMITTER_CLASS: EMITSOP EMITJOP EMITTOP EMITXOP ALLOC_AND_EMIT_TOP **)
C00244 00026 (** DATUM_PROCESSOR_CLASS: LENGTH_TO_INTOPNDTYPE REG_DATUM COERCE_DATUM CVT_INT_DATUM COERCE_INT_DATUM COERCE_TWO_DATUMS DAT_IS_REG DAT_ISFREE_REG DAT_IS_T_REG DAT_IS_FILADR LOADSTKENTRY LOADSTACKEXCEPT BJUMP_TO_BINTVAL INCREMENT_DATUM XCHANGE_STKENTS **)
C00269 00027 (** DATUM_PROCESSOR_CLASS: BINTVAL_TO_BJUMP PARMREG_TO_PARMSAVE INC_INDIRECTION TRANSLATE_LVLDSP **)
C00277 00028 (** DATUM_PROCESSOR_CLASS: IS_SIMPLE FITS_SHRT_OFFSET FITS_SHORT_INDEX IS_CONSTANT IS_CNST_PLUS_OPND PUSHTOP POPTOP PUSH_STKFRAME POP_STKFRAME **)
C00283 00029 (** LITERAL_TABLE_CLASS: UPD_REALTBL UPD_SETTBL UPD_PROCTBL **)
C00288 00030 (** LITERAL_TABLE_CLASS: UPD_LBLTBL UPD_BOUNDTBL **)
C00292 00031 (** GET_OPERAND_CLASS: INSERT_SHORT_VPA VPA_OPERAND_NOSHIFT FIT_IN_OPERAND **)
C00302 00032 (** GET_OPERAND_CLASS: FIT_ADDRESS_IN_OPERAND **)
C00307 00033 (** GET_OPERAND_CLASS: GET_OPERAND GET_SHORT_OPERAND GET_ADDRESS **)
C00311 00034 (** GET_OPERAND_CLASS: MOVE_QUANTITY SLR_QUANTITY COERCE_AND_MOVE_QUANTITY STORE **)
C00318 00035 (** SIMPLIFY_CLASS: ADD_SUB_SINGLE INC_OR_DEC ADD_TOP_TWO_DATUMS MULT_SINGLE SIMPLIFY ADD_VPAS FPA_LVL_PLUS_VPA1 FPA_DSPLMT_PLUS_VPA1 VPA_FPA_FINALIND SHORT_AND_REG CALCULATE_FPA DEREF_AND_SHIFT SHIFT_VPA1 DEREF DEREF_TO_END **)
C00352 00036 (** DISASSEMBLE_CLASS: DISASSEMBLE PRINTLOC PRINTIWORD PRINTXW1 PRINTXW2 PRINTOPERAND PRINTREG PRINT_SIGNED_OCTAL PRINTSHORTOP **)
C00370 00037 (** OBJECT_MODULE_SEGMENT_CLASS: GEN_PSWITCH CODE_CONCRETIZER CONCPAS1 INSERTS1LOC JMPX_TO_JMPA_OPT **)
C00378 00038 (** OBJECT_MODULE_SEGMENT_CLASS: PEEPHOLE_OPTIMIZER SKIP_JMPA_OPT INC_SKP_OPT **)
C00386 00039 (** OBJECT_MODULE_SEGMENT_CLASS: COLLAPSE_MOV_OPT **)
C00396 00040 (** OBJECT_MODULE_SEGMENT_CLASS: PEEPHOLE_OPTIMIZER **)
C00401 00041 (** OBJECT_MODULE_SEGMENT_CLASS: CONCPAS3 PASS3PCRELFIX INSERT_NOP **)
C00411 00042 (** OBJECT_MODULE_SEGMENT_CLASS: INIT_SEGMENT GEN_SEGMENT FIXDISP OPEN_SEGMENT CLOSE_SEGMENT CLEAROUT_TXTBUF OPEN_TXT CLOSE_TXT OUT_TXT **)
C00421 00043 (** OBJECT_MODULE_SEGMENT_CLASS: OPN_SEG CLS_SEG OUT_SEG OPEN_ESD CLS_ESD OUT_ESD OPEN_ESR CLS_ESR OUT_ESR OPEN_RLD CLOSE_RLD OUT_RLD **)
C00430 00044 (** OBJECT_MODULE_SEGMENT_CLASS **)
C00439 00045 (** OBJECT_MODULE_SEGMENT_CLASS **)
C00447 00046 (** CALLSTANDARD_CLASS: SAVE_PARMREGS RESTORE_PARMREGS CALLSTANDARD GENCALL ONE_ARG TWO_SINGLE_ARGS CHECKFILADR ALLOC_EXCESS EXCESS_ARG DEALLOC_EXCESS CHECK_REF_PARM RESULT_PARM **)
C00471 00047 (*** ASSEMBLE_NEXT_INSTRUCTION_CLASS: ASMNXTINST ***)
C00474 00048 (*** ANI_CLASS: ARITH_1_OPS UABS UNEG UADD UINC UDEC ***)
C00479 00049 (*** ANI_CLASS: ARITH_2_OPS USUB ***)
C00487 00050 (*** ANI_CLASS: ARITH_3_OPS UMPY USQR ***)
C00497 00051 (*** ANI_CLASS: ARITH_4_OPS UDIV UDMD UMOD ***)
C00503 00052 (*** ANI_CLASS: COMPARE_SETS REL_OPS UEQU UGEQ UGRT ULEQ ULES UNEQ UIEQU UIGEQ UIGRT UILEQ UILES UINEQ ***)
C00517 00053 (*** ANI_CLASS: BOOL_OPS UAND UIOR UXOR UNOT UODD ***)
C00523 00054 (*** ANI_CLASS: SET_OPS UDIF UINT UUNI UINN USGS UADJ UMUS ***)
C00532 00055 (*** ANI_CLASS: LOAD1_STORE_OPS ULCA ULDA ULDC ULOD ULDP UILOD UPLOD ***)
C00540 00056 (*** ANI_CLASS: LOAD2_STORE_OPS USTR UNSTR UISTR UINST UPSTR UMOV ***)
C00554 00057 (*** ANI_CLASS: FLOW_CONTROL_OPS UTJP UFJP UUJP UXJP UGOOB ULAB UCLAB ***)
C00564 00058 (*** ANI_CLASS: ENVIRONMENT_OPS UBGN UEND USTP UENT UBGNB UENDB ***)
C00571 00059 (*** ANI_CLASS: CHECK_OPS UCHKL UCHKH UCHKT UCHKF UCHKN ***)
C00577 00060 (*** ANI_CLASS: TYPE_CONV_OPS URND UTYP UTYP2 UCVT UCVT2 ***)
C00582 00061 (*** ANI_CLASS: VIRT_STK_OPS UDUP USWP UIXA ***)
C00591 00062 (*** ANI_CLASS: PROC_CALL_OPS UMST UPAR UCUP UICUP UCSP URET ***)
C00612 00063 (*** ANI_CLASS: IMP_EXP_OPS UIMPP UIMPV UEXPP UEXPV ***)
C00613 00064 (*** ANI_CLASS: COMP_TIME_OPS UCOMM UOPTN ULEX USYM ULIVE UDEAD UDOA UDEF UMDEF ULOC ***)
C00621 00065 (*** ANI_CLASS: ***)
C00625 00066 (** READNXTINST_CLASS: READNXTINST READNAM READTYP READMTYP READINT READREAL READSTRING READSET UUNK *)
C00638 00067 (** INITIALIZE_CLASS: INITIALIZE ENTER_OPC ENTER_CSP INIT1 **)
C00662 00068 (** INITIALIZE_CLASS: INIT2 **)
C00680 00069 (** INITIALIZE_CLASS: INIT3 **)
C00705 00070 (** INITIALIZE_CLASS: INIT4 **)
C00730 00071 (** INITIALIZE_CLASS: INIT5 **)
C00754 00072 (** INITIALIZE_CLASS: INIT6 **)
C00762 00073 (** INITIALIZE_CLASS: INIT7 **)
C00774 00074 (** INITIALIZE_CLASS: **)
C00775 00075 (** MAIN_PROGRAM: **)
C00783 ENDMK
C⊗;
(*PROGRAM HEADER PAGE*)
(*%SETF D10*) (*DEC-10 VERSION?*)
(*%SETT SET4*) (*4-WORD SETS ALLOWED BY HOST COMPILER?*)
(*%SETT ASCII*) (*ASCII USED FOR CHARACTERS?*)
(*%IFT D10*)
(*$Y-,O-,D+,R64,S2000*) (*PAS10 OPTIONS*) (*2AUG79 PTZ*)
(*%ELSE*)
%(*$X+,B+,D+,M120*) (*PCPASC OPTIONS*) (*4AUG79 PTZ*)\
(*%ENDC*)
(* EXPLANATION OF PAS10 OPTIONS DEFAULT
D+ DEBUG AND POSTMORTEM DUMP -
E+ EXTERNAL CALLS TO LEVEL 1 PROCEDURES ALLOWED -
Fn FILE OPTION 1
I+ FORTRAN I/O IN EXTERNAL FORTRAN SUBROUTINES -
L+ OBJECT LISTING -
Rn SIZE OF LOW-SEGMENT (SEE PAS10 MANUAL)
Sn MAX INSTRUCTIONS PER STATEMENT 1000
T+ RUNTIME CHECK +
U+ 72 COLUMN FORMAT -
Xn HIGHEST REGISTER FOR PARAMETERS 6
*)
(* EXPLANATION OF PCPASC OPTIONS DEFAULT
A+ GENERATE S1 ASSEMBLY MODULE -
A- GENERATE S1 OBJECT MODULE
B+ BOUNDS CHECKING, BUT ALLOW 'BIG' CHARACTERS -
C+ EMIT PCODE +
D+ RUNTIME CHECKING OF POINTER, INDEX, SUBRANGE VALUES -
E+ FILE IS IN EBCDIC CHARACTER SET -
F+ SAVE FPR'S ON PROCEDURE/FUNCTION ENTRY +
K+ ENABLE STATEMENT EXECUTION COUNTING -
L+ LIST SOURCE PROGRAM +
M+ 72 COLUMN FORMAT +
P+ DOUBLE-WORD BOUNDARY ALIGNMENT -
S+ SAVE GPR'S ON PROCEDURE/FUNCTION ENTRY +
T+ PRINT SYMBOL TABLES (FOR POST-PROCESSOR) -
U+ GET STATISTICS?? 2ND PARAMETER TO PCODE BGN INSTR. -
V+ ?? 3RD PCODE BGN INSTRUCTION PARAMETER -
X+ USE ACTUAL PROCEDURE NAMES FOR EXTERNAL REFERENCES -
X- GENERATE UNIQUE 8-CHAR NAMES FOR EXTERNAL REFERENCES
*)
(*%IFT D10*)
program SOPAIPILLA (INPUT*,OUTPUT,PRR);
(*%ELSE*)
%program SOPAIPILLA (INPUT,OUTPUT,PRR);\
(*%ENDC*)
(*SOPAIPILLA - Stanford Optimizing Packed-Address Implementation of a
universal Pcode Intermediate Language Logical Assembler*)
(*CAVEAT : This is a preliminary version of this program. It should not
be considered in any sense in final form, since it is undergoing daily
development and modification.*)
(*This program translates P-Code, an intermediate language invented as a
target language of a PASCAL compiler, into S-1 machine language. During
the translation process, a number of local optimizations are performed. A
detailed description of the logic of the program, including discussion of
the optimizations performed is contained in the document SOPADOPE*)
(*SOPAIPILLA was written during summer 1977 by Erik J. Gilbert and David
W. Wall of the Computer Science Department at Stanford University. Much
of its internal philosophy is based on a similar compiler for the IBM 370
written by Sassan Hazeghi, also of the Stanford C.S. Dept.*)
(* This version, SUPG01, is descended from:
SOPU[S1,ALS] 23AUG79
SOPZ21[SOP,S1] 18AUG79
*)
(* Compiler-option constants... *)
const
SOPA_ID = 'SUPG03, version of 27SEP79 13:33 (PN)';
(*%IFT ASCII*)
CHARDIF = 0;
(*%ELSE*)
%CHARDIF = 40B;\
(*%ENDC*)
(* LCW 2AUG78
This compiler will not compile programs containing constants outside the
range of MIN_ON_COMP_MACH..MAX_ON_COMP_MACH. Furthermore,
MAX_ON_COMP_MACH and MIN_ON_COMP_MACH must be set to the minimum and
maximum values, respectively, of integers of the machine on which this
compiler runs. BITS_ON_COMP_MACH must be set to the number of bits in
an integer of the machine on which the compiler runs. However, when
running the compiler on a machine with a word size larger than that of
the S1, these constants must be set as if that machine had a word size
equal to that of the S1. Never try to run this program on a machine with
word length less than 32.
*)
(*MAX_ON_COMP_MACH = 2147483647; " 2**31 - 1 (370) " *)
(*MIN_ON_COMP_MACH = -2147483648; " -2**31 (370) " *)
(*BITS_ON_COMP_MACH = 32; " 370 " *)
(*MAX_EXP_ON_COMP_MACH = 30; " two less than bits " *)
MAX_ON_COMP_MACH = 34359738367; " 2**35 - 1 (10/S1) "
MIN_ON_COMP_MACH = -34359738367; " -2**35 (10/S1) "
(* MIN_ON_COMP_MACH should be one less, but runtime won't accept it ... *)
BITS_ON_COMP_MACH = 36; " 10/S1 "
MAX_EXP_ON_COMP_MACH = 34; " two less than bits "
BLKMOV_THRESH = 225; (*PMOVs of >= 225 QWs generate BLKMOV*)
(*Everything < 225 QWs can be done with
at most 3 MOVMQs or 2 MOVMSs*)
MINPARS1REG = 8; (*smallest numbered parameter register*)
MAXDSPS1REG = 29; (*largest numbered display register*)
MAXPAREG = 10; (*Maximum number of parameter registers*)
MAXPAREGM1 = 9; (*Maximum logical index of a parameter reg*)
MINBLOCK = 1; (*Minimun legal number for a memory block*)
MAXBLOCK = 500; (*Maximum legal number for a memory block*)
ILLBLOCKNO = -1; (*Illegal block number for initialization*)
MAXLVL = 8; (*Maximum nesting of procedure declarations*)
MAXLBL = 99999; (*Maximum label integer*)
MAXCODEW = 999999; (*Maximum number of words in a CODEREC*)
ALFASIZE = 16; (*Maximum length of type ALFA*)
COMMLEN = 64; (*Maximum printed length of the comment field
in a COMM instruction. *)(*peg 24aug79*)
STRINGMAX = 150; (*Maximum length of a string, in characters*)
SEG_START_RELPC = 0; (*Relative PC of segment start*)
SEG_EP_DISP = 16; (*Storage units from seg start to entry point*)
TMPDATAWORDSGUESS = 3;
SFLDMAX = 3; (*VPA shift maximum*)
NILVAL = -1;
MAXS1LOC = 16777215; (*2**24-1 - really should be = MAXS1ADDR, 2**30-1*)
S1LOCUNDEF = MAXS1LOC;
MAXPEEP_PASSES = 2; (*Maximum number of passes in PEEPHOLE_OPTIMIZER*) (*PTZ*)
MINSTKINX = -1;
MAXSTKINX = 30; (* peg 09jul79 -- may have to be increased.*)
TMPD1 = MINSTKINX; (*TMPD1 is used to hold synthetic DATUMs*)
MINFRAME = 1; (* peg 09jul79 *)
MAXFRAME = 15; (* peg 09jul79 *) (*Same as MAXMST*)
MAXMST = 15; (*Maximum nesting of function calls*)
MAXESDINDEX = 1000;
MAXESRINDEX = 1000;
MAXZINDEX = 1000; (*max of two above*)
LBLHTSIZE = 197; (*prime*)
LBLHTSIZEM1 = 196;
CSPHTSIZE = 91; (*prime*)
CSPHTSIZEM1 = 90;
OPCHTSIZE = 263; (* ALS 7/16/79*)
OPCHTSIZEM1 = 262;
(*OPCHTSIZE = 197;*) (*prime*)
(*OPCHTSIZEM1 = 196;*)
(*370 values for 4 constants ... *)
(*
LCAFTMST = 80;
FNCRSLT = 72;
LASTFILBUF = 280;
L1LOCALDATATRANSLATION = 408; "*LASTFILBUF - MINSHORTOFFSET*WORDUNITS*"
*)
(*S1 valuesfor 4 constants ... *)
LCAFTMST = 8;
FNCRSLT = 0;
LASTFILBUF = 44; (*level 1 dsplmt of first local variable,
which is after level 1 MST part.*)
(* L1LOCALDATATRANSLATION = 172; *) (*LASTFILBUF - MINSHORTOFFSET*WORDUNITS*)
(* ↑ commented out: peg 27jul79 *)
LCIOFILADR = 8; (*level 1 dspl of the global variable used
to store current I/O file addr*)
(* Address tranlation constants -- als/peg 18jul79...*)
FIRSTADDR = 0; (*Address (in qwords) of first local variable for
> L1 procedures = FNCRSLT*)
L1FIRSTADDR = 44; (*Address (in qwords) of first local variable for
L1 procedures = LASTFILBUF*)
OFFSET_IN_VARS = 128; (*Offset of display in local variable area =
-MINSHORTOFFSET*WORDUNITS *)
R_OFFSET = -172; (*Offset of RegParmSaveArea from display =
-REGIMAGEAREASIZE - OFFSET_IN_VARS*)
M_OFFSET = -128; (*Offset of beginning of M memory area from
display = -OFFSET_IN_VARS*)
DISPLAY_OFFSET = 172; (*Offset of display from beginning of segment, not
including the EvalSaveArea, for > L1 procedures*)
L1DISPLAY_OFFSET = 172; (*Offset of display from beginning of segment, not
including the EvalSaveArea, for L1 procedure*)
FILE_OFFSET = -172; (*Offset of file buffers from display =
-FILBUFAREASIZE - OFFSET_IN_VARS*)
REGIMAGEAREASIZE = 44; (*Size of Register Image Area, in quarterwords =
(MAXPAREG + 1)*WORDUNITS*)
FILBUFAREASIZE = 44; (*Size of File Buffer Area, in quarterwords =
LASTFILBUF*)
(*...Address tranlation constants -- als/peg 18jul79 *)
(* ...end compiler-option constants *)
(* Constants fixed by S1 architecture... *)
FIRSTS1REG = 0;
S1RCPL = 0; (*register to start CPL block-descriptor*)
S1R0 = 0;
S1RPC = 3;
S1RTA = 4;
S1RTB = 6;
S1RSP = 30; (*stack-pointer register*)
S1RNP = 31; (*heap-pointer register*)
LASTS1REG = 31;
S1RNPMEMADR = 124; (*memory address of S1RNP*) (*BNDTRPKLU*)
FIRSTS1GBL = 32; (*globals are low-core memory words*)
S1GMEMEND = 32; (*runtime sets up address of last QW of heap here*)
S1GSEGBASE = 33; (*global number of segment base for trace*)
S1GBLZ = 34; (*global number of zero word for block descriptor use*)
S1GCPLPL = 35; (*global number of CPLPL block-descriptor*)
LASTS1GBL = 39; (*number of last S1 low-core global*)
(*DO NOT assign globals beyond 47 (octal addr 276) without
also changing FSIM, PASRUN, and S1 DDT. - EJG 26JAN79 *)
MAXS1ADDR = 1073741823; (*2**30 - 1*) (*EJG*)
MINS1DISP = -16777216; (*-2**24*)
MAXS1DISP = 16777215; (*2**24 - 1*)
MINSIGNEDS1ADDR = -536870912; (*-2**29*)
MAXSIGNEDS1ADDR = 536870911; (*2**29-1*)
MINSHORTOFFSET = -32;
MAXSHORTOFFSET = 31;
MINSHORTCONSTANT = -32;
MAXSHORTCONSTANT = 31;
MAXINDEXSHIFT = 3;
MINJPROFFSET = -2048;
MAXJPROFFSET = 2047;
MINSKPOFFSET = -8;
MAXSKPOFFSET = 7;
MAXMOVMQ = 32; (*64 and 128 are handled specially*)
(*MAXMOVMQ must be a multiple of WORDUNITS*)
MAXMOVMS = 32; (*5DEC78 ALS*)
S1TRUEFLAG = -1;
DALIGNSHIFT = 3;
DALIGNMUL = 8;
CHARBITS = 9;
QWBITS = 9;
HWBITS = 18;
WORDBITS = 36;
DWBITS = 72; (* peg 09jul79 *)
WORDCHARS = 4;
QUARTERWORDUNITS = 1;
HALFWORDUNITS = 2;
WORDUNITS = 4;
DOUBLEWORDUNITS = 8;
PAGEUNITS = 2048;
MAXALIGNBOUNDARY = 4;
SET_SIZE = 144; (*Number of set elements on the S1.*)
SET_MAX = 143; (*Max legal value of a set element on the S1.*)
S1SETREP_SIZE = 4; (*Number of S1 words used/set.*)
S1SETREP_MAX = 3; (*Number of S1 words used/set - 1.*)
NUMOFSETPARTS = 2; (*Number of double-word parts/set.*)
SETPART_MAX = 1; (*Number of double-word parts/set - 1.*)
(*%IFF SET4*)
HOST_SET_SIZE = 64; (*Number of set elements/set in host compiler.*)
HOST_SET_MAX = 63; (*Max legal value of a host set element.*)
SETREP_MAX = 2; (*Number of host sets used/set - 1.*)
(*%ELSE*)
%HOST_SET_SIZE = 144; (*Number of set elements/set in host compiler.*)\
%HOST_SET_MAX = 143; (*Max legal value of a host set element.*)\
(*%ENDC*)
OPCODE_START = 0; OPCODE_LEN = 12;
OPND1_START = 12; OPND1_LEN = 12;
OPND2_START = 24; OPND2_LEN = 12;
T_START = 10; T_LEN = 2;
PR_START = 11; PR_LEN = 1;
SKP_START = 8; SKP_LEN = 4;
J_START = 24; J_LEN = 12;
FAKEOPND_START = 12; FAKEOPND_LEN = 24;
OPND_START = 0; OPND_LEN = 12; (*PTZ*)
OPNDX_START = 0; OPNDX_LEN = 1;
OPNDREG_START = 1; OPNDREG_LEN = 5;
OPNDF_START = 6; OPNDF_LEN = 6;
OPND1X_START = 12; OPND1X_LEN = 1;
OPND1REG_START = 13; OPND1REG_LEN = 5;
OPND1F_START = 18; OPND1F_LEN = 6;
OPND2X_START = 24; OPND2X_LEN = 1;
OPND2REG_START = 25; OPND2REG_LEN = 5;
OPND2F_START = 30; OPND2F_LEN = 6;
XWP_START = 0; XWP_LEN = 1;
XWV_START = 1; XWV_LEN = 1;
XWD_START = 2; XWD_LEN = 1;
XWI_START = 3; XWI_LEN = 1;
XWS_START = 4; XWS_LEN = 2;
XWADDR_START = 6; XWADDR_LEN = 30;
XWREG_START = 6; XWREG_LEN = 5;
XWDISP_START = 11; XWDISP_LEN = 25;
BNDTYP_START = 0; BNDTYP_LEN = 9;
RGS = 0; MEM = 1; (*should be enum. type, but alignment*)
(* ...end constants fixed by S1 architecture *)
type
ERRORCODE = (
WARITH_ON_WRONG_DT,
WNOT_IMPLEMENTED,
WILLEGAL_LABEL,
WABS_OR_NEG_OF_NONSIGNED,
WADDR_OUT_OF_RANGE,
WADDRESS_CHECK_ON_NONADDRESS,
WALIGNMENT_ERROR,
WANDOR_NEEDS_BOOLEAN,
WBGN_STP_NAME_MISMATCH,
WENT_AND_PLOD_INCONSISTENT,
WENT_END_NAME_MISMATCH,
WENT_SPECIFIED_WRONG_PARMS,
WBINARY_OPND_TYPE_CONFLICT,
WBOOL_IS_TRUE,
WBOOL_NOT_TRUE,
WCHECKED_CONSTANT_OUT_OF_RANGE,
WCHKF_CHKT_NEEDS_BOOLEAN,
WCHKN_NULL_TOP,
WCHKN_NOT_ADDRESS,
WCHECKING_INVALID_TYPE,
WCHR_NEEDS_INT,
WCOERCION_INVALID,
WCOMPARE_ILLEGAL,
WCOMPM_NEEDS_ADDR,
WCONST_OUT_OF_RANGE_FOR_SET,
WDISP_OUT_OF_RANGE,
WDUP_ON_EMPTY_STACK,
WEQU_etc_with_TYP_is_TYPM,
WEXPR_TOO_COMPLEX,
WFILE_ADDRESS_NEEDED,
WTJP_FJP_NEEDS_BOOLEAN,
WTJP_FJP_WITH_NONEMPTY_STACK,
WFIX_OF_INVALID_TYPE,
WFLOAT_OF_INVALID_TYPE,
WFUNC_CALLS_NESTED_TOO_DEEPLY,
WIEQU_etc_with_TYP_not_TYPM,
WILLEGAL_PROC_TYPECODE,
WINCOMPATIBLE_TYPES,
WINDEX_WITHOUT_BASE,
WINDEXING_IN_PARMS,
WINN_REQUIRES_SET_ON_TOP_OF_STACK,
WINSTR_TYPE_NOT_DATUM_TYPE,
WINSUFF_PARMS_SPECIFIED,
W2_MANY_PARMS_SPECIFIED,
WINTEGER_CONSTANT_DIV_MOD_BY_ZERO,
WINVAL_BLOCK_NUMBER,
WINVAL_CSP,
WINVAL_OPC,
WINVAL_TRACE,
WINVAL_TYP_ON_LDC,
WINVAL_U_TYPECODE,
WINVALID_DISPLACEMENT,
WINVALID_TYPE_COERCION,
WINVALID_LEVEL,
WINVALID_MEMORY_TYPE,
WIXA_NEEDS_ADDR,
WL_LPTR_LBLNUM_UNDEFINED,
WLAST_SST_PARM_TOO_BIG,
WLOADING_STRING,
WISTR_INST_NEEDS_ADDRS,
WMOV_NEEDS_ADDRS,
WMST_SPECIFIED_INSUFF_PARM_STORAGE,
WMST_WITHOUT_CUP_IN_LAST_SEGMENT,
WMULT_DEFINED_LAB,
WNESTING_TOO_DEEP_OR_EXPRESSION_TOO_COMPLEX,
WNEW_MUST_HAVE_ADDR_AND_INT,
WNOT_AN_ADDR,
WNOT_DISCRETE_TYPE,
WNOT_NEEDS_BOOLEAN,
WNULLREF,
WODD_REQUIRES_AN_INTEGER,
WORD_NEEDS_INT_BOOLEAN_OR_CHAR,
WPOP_OF_EMPTY_STACK,
WREAL_CONSTANT_DIVISION_BY_ZERO,
WREGPARMS_SPEC_TOO_LOW_IN_MST,
WROUND_OF_NON_REAL, (*ROUND*)
WRST_NEEDS_ADDR,
WSAV_NEEDS_ADDR,
WSET_OPERATION_ON_NONSET_TYPES,
WSGS_OR_INN_REQUIRES_INT_CHAR_OR_BOOLEAN,
WSIO_DIDNT_SEE_FILEADDR,
WSIO_WITH_NONADDRESS,
WSQUARE_OF_INVALID_TYPE,
WSTACK_LEFT_NONEMPTY_IN_LAST_SEGMENT,
WSTACK_NON_EMPTY,
WSTACK_NOT_SINGLE,
WSWP_NOT_2,
WSWP_TYP_ERROR,
W2_MANY_BGNBS,
W2_MANY_ENDBS,
WTOO_LARGE_K_OR_L,
WTRUNCATE_OF_INVALID_TYPE,
WCVT_WITH_INVALID,
WTYP_WITH_INVALID,
WUJP_WITH_NONEMPTY_STACK,
WWRONG_INSTR_DATATYPE,
WWRONG_COMPARE,
WWRONG_RESULT_NUMBER,
WXJP_WITHOUT_SINGLETON_STACK);
(* Corrected list June 7, 1979*)
U_OPCODE = (
UABS ,UADD ,USUB ,UMPY ,UDIV ,UADJ ,UAND ,UBGN ,UBGNB,UCHKF,
UCHKH,UCHKL,UCHKN,UCHKT,UCLAB,UCOMM,UCSP ,UCUP ,UCVT ,UCVT2,
UDEAD,UDEC ,UDEF ,UDIF ,UDMD ,UDOA ,UDSP ,UDUP ,UEND ,UENDB,
UENT ,UEXPP,UEXPV,UFJP ,UICUP,
UGOOB,UMOV , (*UMOV added 30Jun79 by peg*)
UEQU ,UNEQ ,UGEQ ,UGRT ,ULEQ ,
ULES ,UIEQU,UINEQ,UIGEQ,UIGRT,UILEQ,UILES,UILOD,UIMPP,
UIMPV,UINC ,UINN ,UINST,UINT ,UIOR ,UISTR,UIXA ,ULAB ,ULCA ,
ULDA ,ULDC ,ULDP ,ULEX ,ULIVE,ULOC ,ULOD ,UMDEF,UMOD ,UMST ,
UMUS ,UNEG ,UNEW ,UNOT ,UNSTR,UODD ,UOPTN,UPAR ,UPLEX,UPLOD,
UPSTR,URET ,URND ,USDEF,USGS ,USQR ,USTP ,USTR ,USWP ,USYM ,
UTJP ,UTYP ,UTYP2,UUJP ,UUNI ,UUNK ,UXJP ,UXOR );
P_STANDARDPROC = (
QATN, QCLK, QCOS, QEIO, QELN, QEOF, QEXP, QGET, QLOG, QNEW,
QPUT, QRDB, QRDC, QRDI, QRDR, QRDS, QRES, QREW, QRLN, QRND, (*ROUND*)
QRST, QSAV, QSIN, QSIO, QSQT, QTRP, QWLN, QWRB, QWRC, QWRI,
QWRR, QWRS, QXIT);
S1OPCODE = (
XILLEGAL,
XPLOC,
XS1LOC,
XFREEREG, (*PBK*)
XABS_Q,
XABS_H,
XABS_S,
XABS_D,
XADD_S,
XADD_D,
XADJSP_UP,
XADJSP_DN,
XALLOC_1,
XAND_Q,
XAND_D,
XAND_TC_D,
XAND_CT_D,
XBLCMP_EQL_Q,
XBLCMP_NEQ_Q,
XBLCMP_GEQ_Q,
XBLCMP_GTR_Q,
XBLCMP_LEQ_Q,
XBLCMP_LSS_Q,
XBLKMOV,
XBTRP_B_Q,
XBTRP_B_H,
XBTRP_B_S,
XBTRP_B_D,
XBTRP_M1_Q,
XBTRP_M1_H,
XBTRP_M1_S,
XBTRP_M1_D,
XBTRP_0_Q,
XBTRP_0_H,
XBTRP_0_S,
XBTRP_0_D,
XBTRP_1_Q,
XBTRP_1_H,
XBTRP_1_S,
XBTRP_1_D,
XDEC_S,
XDJMPA, (*25JUN79 PTZ...*)
XDSKP_EQL, (*start of S1SKIPOPCODE*)
XDSKP_NEQ,
XDSKP_GEQ,
XDSKP_GTR,
XDSKP_LEQ,
XDSKP_LSS, (*...25JUN79 PTZ*)
XFX_DM_S_S,
XFX_DM_S_D,
XFX_FL_S_S,
XFLOAT_S_Q,
XFLOAT_S_H,
XFLOAT_S_S,
XFLOAT_S_D,
XFADD_S,
XFADD_D,
XFSUB_S,
XFSUBV_S,
XFSUB_D,
XFSUBV_D,
XFMULT_S,
XFMULT_D,
XFDIV_S,
XFDIVV_S,
XFDIV_D,
XFDIVV_D,
XFTRANS_S_D,
XFTRANS_D_S,
XHALT, (*BNDTRPKLU*)
XIJMPA, (*25JUN79 PTZ*)
XINC_S,
XISKP_EQL, (*25JUN79 PTZ...*)
XISKP_NEQ,
XISKP_GEQ,
XISKP_GTR,
XISKP_LEQ,
XISKP_LSS, (*...25JUN79 PTZ*)
XJMPA,
XJMPZ_EQL_Q,
XJMPZ_NEQ_Q, (* als/peg 19jul79 *)
XJSR,
XMOV_A,
XMOV_Q_Q,
XMOV_Q_H,
XMOV_H_Q,
XMOV_H_H,
XMOV_Q_S,
XMOV_H_S,
XMOV_S_Q,
XMOV_S_H,
XMOV_S_S,
XMOV_Q_D,
XMOV_H_D,
XMOV_S_D,
XMOV_D_Q,
XMOV_D_H,
XMOV_D_S,
XMOV_D_D,
XMOVMQ_2,
XMOVMQ_3,
XMOVMQ_4,
XMOVMQ_5,
XMOVMQ_6,
XMOVMQ_7,
XMOVMQ_8,
XMOVMQ_9,
XMOVMQ_10,
XMOVMQ_11,
XMOVMQ_12,
XMOVMQ_13,
XMOVMQ_14,
XMOVMQ_15,
XMOVMQ_16,
XMOVMQ_17,
XMOVMQ_18,
XMOVMQ_19,
XMOVMQ_20,
XMOVMQ_21,
XMOVMQ_22,
XMOVMQ_23,
XMOVMQ_24,
XMOVMQ_25,
XMOVMQ_26,
XMOVMQ_27,
XMOVMQ_28,
XMOVMQ_29,
XMOVMQ_30,
XMOVMQ_31,
XMOVMQ_32,
XMOVMQ_64,
XMOVMQ_128,
XMOVMS_2, (*through MOVMS_32 added 5/dec/78 ALS*)
XMOVMS_3,
XMOVMS_4,
XMOVMS_5,
XMOVMS_6,
XMOVMS_7,
XMOVMS_8,
XMOVMS_9,
XMOVMS_10,
XMOVMS_11,
XMOVMS_12,
XMOVMS_13,
XMOVMS_14,
XMOVMS_15,
XMOVMS_16,
XMOVMS_17,
XMOVMS_18,
XMOVMS_19,
XMOVMS_20,
XMOVMS_21,
XMOVMS_22,
XMOVMS_23,
XMOVMS_24,
XMOVMS_25,
XMOVMS_26,
XMOVMS_27,
XMOVMS_28,
XMOVMS_29,
XMOVMS_30,
XMOVMS_31,
XMOVMS_32,
XMULT_S,
XMULT_D,
XDIV_S, (* added 18jul79 als/peg *)
XNEG_Q,
XNEG_H,
XNEG_S,
XNEG_D,
XNOP,
XOR_Q,
XOR_D,
XQUO_S,
XQUOV_S,
XQUO_D,
XQUOV_D,
XREM_S,
XREMV_S,
XREM_D,
XREMV_D,
XRETSR,
XSHF_LF_D,
XSHFV_LF_D,
XSHFA_LF_S,
XSHFAV_LF_S,
XSKP_EQL_Q, (*Start of S1SKIPOPCODE subrange*)
XSKP_NEQ_Q,
XSKP_GEQ_Q,
XSKP_GTR_Q,
XSKP_LEQ_Q,
XSKP_LSS_Q,
XSKP_EQL_H,
XSKP_NEQ_H,
XSKP_GEQ_H,
XSKP_GTR_H,
XSKP_LEQ_H,
XSKP_LSS_H,
XSKP_EQL_S,
XSKP_NEQ_S,
XSKP_GEQ_S,
XSKP_GTR_S,
XSKP_LEQ_S,
XSKP_LSS_S,
XSKP_EQL_D,
XSKP_NEQ_D,
XSKP_GEQ_D,
XSKP_GTR_D,
XSKP_LEQ_D,
XSKP_LSS_D,
XSKP_NON_Q,
XSKP_NON_H,
XSKP_NON_S,
XSKP_NON_D,
XSKP_ANY_Q,
XSKP_ANY_H,
XSKP_ANY_S,
XSKP_ANY_D, (*End of S1SKIPOPCODE subrange*)
XSLR_0,
XSLR_1,
XSLR_2,
XSLR_3,
XSLR_4,
XSLR_5,
XSLR_6,
XSLR_7,
XSLR_8,
XSLR_9,
XSLR_10,
XSLR_11,
XSLR_12,
XSLR_13,
XSLR_14,
XSLR_15,
XSLR_16,
XSLR_17,
XSLR_18,
XSLR_19,
XSLR_20,
XSLR_21,
XSLR_22,
XSLR_23,
XSLR_24,
XSLR_25,
XSLR_26,
XSLR_27,
XSLR_28,
XSLR_29,
XSLR_30,
XSLR_31,
XSLRADR_0,
XSLRADR_1,
XSLRADR_2,
XSLRADR_3,
XSLRADR_4,
XSLRADR_5,
XSLRADR_6,
XSLRADR_7,
XSLRADR_8,
XSLRADR_9,
XSLRADR_10,
XSLRADR_11,
XSLRADR_12,
XSLRADR_13,
XSLRADR_14,
XSLRADR_15,
XSLRADR_16,
XSLRADR_17,
XSLRADR_18,
XSLRADR_19,
XSLRADR_20,
XSLRADR_21,
XSLRADR_22,
XSLRADR_23,
XSLRADR_24,
XSLRADR_25,
XSLRADR_26,
XSLRADR_27,
XSLRADR_28,
XSLRADR_29,
XSLRADR_30,
XSLRADR_31,
XSUB_S,
XSUBV_S,
XSUB_D,
XSUBV_D,
XTRANS_Q_Q,
XTRANS_Q_H,
XTRANS_H_Q,
XTRANS_H_H,
XTRANS_Q_S,
XTRANS_H_S,
XTRANS_S_Q,
XTRANS_S_H,
XTRANS_S_S,
XTRANS_Q_D,
XTRANS_H_D,
XTRANS_S_D,
XTRANS_D_Q,
XTRANS_D_H,
XTRANS_D_S,
XTRANS_D_D,
XXOR_Q);
HARDS1OPCODE = 0..4095;
S1SKIPOPCODE = XDSKP_EQL..XSKP_ANY_D; (*28JUN79 PTZ*)
(*
OPNDTYPE = (ILLARITH, ILLCOMP,
TYPA, TYPM, TYPN, TYPB, TYPC, TYPS, TYPQ,
TYPH, TYPI, TYPD, TYPX, TYPR, TYPP, TYPJ);
*)
OPNDTYPE = (ILLARITH, ILLCOMP,
TYPUA, TYPUB, TYPUC, TYPUE, TYPQ, TYPH, TYPUI, TYPUJ, TYPUK,
TYPUL, TYPUM, TYPUN, TYPUP, TYPUQ, TYPUR, TYPUS);
MEMTYPE = (NON_SPACE, R_SPACE, M_SPACE);
S1PRECISION = (S1ILLEGAL, S1Q, S1H, S1S, S1D);
S1LENGTH = 0..8; (*QW LENGTH OF A BASIC S1 PRECISION*)
S1OPFORMAT = (VFAKEOP, VTOP, VJOP, VXOP, VSOP);
ALIGNMENTBOUNDARY = 0..MAXALIGNBOUNDARY;
S1REGISTER = FIRSTS1REG..LASTS1REG;
SETOFS1REGS = set of S1REGISTER; (*PEG*)
S1GBL = FIRSTS1GBL..LASTS1GBL;
S1ADDRESS = 0..MAXS1ADDR;
S1DISP = MINS1DISP..MAXS1DISP;
S1BITNUM = 0..35;
S1SKIPDISTANCE = MINSKPOFFSET..MAXSKPOFFSET;
BIT = 0..1;
TWOBITS = 0..3;
THREEBITS = 0..7; (*DATASTRCH*)
EIGHTEENBITS = 0..262143; (*DATASTRCH*)
IWDRNG = 0..3; (*DATASTRCH*)
OPND_INTEGER = 0 .. 4095; (*8MAR79 PTZ*)
S1RELADR = 0..1073741823; (*2**30 - 1*)
ESDINDEX = 1..MAXESDINDEX;
ESRINDEX = 1..MAXESRINDEX;
ZINDEX = 1..MAXZINDEX;
BANK = integer (*should be (RGS, MEM), but alignment*);
LINTVAL_OR_LINSTPTR = (LINTVAL,LINSTPTR); (*DATASTRCH*)
XW_EV_OR_XW_C = (XW_EV,XW_C);
A_CODEREC = ↑CODEREC;
AN_INSTREC = ↑INSTREC; (*DATASTRCH*)
AN_OPERANDXWORD = ↑OPERANDXWORD; (*DATASTRCH*)
AN_OPNDXWORDREC = ↑OPNDXWORDREC; (*DATASTRCH*)
AN_OPND2REC = ↑OPND2REC; (*DATASTRCH*)
A_LBLHASHENT = ↑LBLHASHENT;
A_PROCENT = ↑PROCENT;
BITFIELD_LENGTH = 1..WORDBITS;
LBL_INDEX = -2..MAXLBL; (* labels -2 to 0 reserved for SOPA use (DEF,XJP) *)
NUMBER_OF_PAREGS = 0..MAXPAREG;
RNG_0_LBLHTSIZEM1 = 0..LBLHTSIZEM1;
DTYPE_LENGTH = integer; (*bit length for valid UCode entities*)
INDIRECTION = (IND0, IND1, IND2);
SFLDRNG = 0..SFLDMAX; (*VPA shift range*)
STKINX = MINSTKINX..MAXSTKINX;
FRAMEINX = MINFRAME..MAXFRAME; (* peg 09jul79 *)
OPNDTYPE_TO_BOOLEAN_ARRAY = array [OPNDTYPE] of boolean;
(*When *real* S1 words exist, this will just be an integer.*)
S1WORD =
packed record (*DATASTRCH*)
LHALF : EIGHTEENBITS; (*DON'T change this without modifying*)
RHALF : EIGHTEENBITS; (*assembly-coded GETFIELD, etc - PTZ*)
end (*S1WORD*);
(*setch...*)
HOST_SET_EL_TYP = 0..HOST_SET_MAX;
HOST_SET_TYP = set of HOST_SET_EL_TYP; (*Set available on host machine.*)
SET_EL_TYP = 0..SET_MAX;
(*%IFF SET4*)
SETREP_INDEX = 0..SETREP_MAX;
SETREP = array [SETREP_INDEX] of HOST_SET_TYP;
(*SOPA-internal representation of full S1 set.*)
(*%ELSE*)
% SETREP = HOST_SET_TYP; \
(*%ENDC*)
S1SETREP_INDEX = 0..S1SETREP_MAX;
S1SETREP = array [S1SETREP_INDEX] of S1WORD; (*S1 set representation.*)
SETPART_INDEX = 0..SETPART_MAX;
(*...setch*)
(*%IFT D10*)
(*%IFT ASCII*)
char = ascii;
(*%ENDC*)
(*%ENDC*)
CHAR2 = packed array [1..2] of char;
CHAR3 = packed array [1..3] of char;
CHAR4 = packed array [1..4] of char;
CHAR10 = packed array [1..10] of char;
CHAR12 = packed array [1..12] of char;
CHAR15 = packed array [1..15] of char;
CHAR17 = packed array [1..17] of char;
CHAR64 = packed array [1..64] of char;
ALFALEN = 1..ALFASIZE;
ALFA = packed array [ALFALEN] of char;
NAMEREC = record NAM : ALFA; LEN : ALFALEN end;
STRINGTYPE = packed array [1..STRINGMAX] of char; (*als/peg 24jul79*)
STRINX = 0..STRINGMAX; (*als/peg 24jul79*)
NONNEGINT = 0..MAX_ON_COMP_MACH;
ZSYMBOL = packed array [1..8] of char; (*external symbol name*)
ZSEGTYPE = (ZIS,ZDS,ZCM);
ZESDTYPE = (ZST,ZIN,ZDN,ZAN);
ZESRTYPE = (ZIR,ZDR,ZAR,ZXR);
ZOPR = (ZPLUS,ZMINUS);
ZESDESRSEG = (ZESD,ZESR,ZSEG);
OPNDNUM = (OPND1NUM,OPND2NUM); (*DATASTRCH*)
INSTBUFINX = (S1INST,S1OPND2XWD,S1OPND1XWD); (*DATASTRCH*)
CODEREC =
record
NEXTPTR : A_CODEREC;
CODEWORD : S1WORD
end (*CODEREC*);
INSTOPND = (*packing tuned for PDP-10 2SEP79 PTZ*) (*DATASTRCH*)
packed record
XWD : AN_OPERANDXWORD; (*X field = 1 iff XWD ≠ nil*)
REG : S1REGISTER;
F : MINSHORTOFFSET..MAXSHORTOFFSET;
end (*INSTOPND*);
INSTREC = (*packing tuned for PDP-10 2SEP79 PTZ*) (*DATASTRCH*)
packed record
PREVPTR : AN_INSTREC; (*new list is doubly-linked*)
NEXTPTR : AN_INSTREC;
INSTOPND1 : INSTOPND;
INSTOPND2 : INSTOPND;
IWDS : IWDRNG; (*# of S-1 words taken by this instr*)
OPCODE : S1OPCODE;
case OPFMT : S1OPFORMAT of
VFAKEOP:(FAKEOPND : integer);
VXOP: ( );
VTOP: (T : TWOBITS);
VJOP,VSOP:(PR : BIT;
DUMMYSPACE : THREEBITS; (*make DESTPTR start on HW bndry*)
DESTPTR : AN_INSTREC;
case BIT of
0: (J : MINJPROFFSET..MAXJPROFFSET);
1: (SKP : MINSKPOFFSET..MAXSKPOFFSET));
end (*INSTREC*);
INSTREC_PTRINT = (* a kludge for printing ptr values for debugging *)
record (*14JAN79 PTZ*)
case BIT of
0 : (PTR : AN_INSTREC); (*DATASTRCH*)
1 : (INT : integer);
end (*INSTREC_PTRINT*);
OPNDXWORDREC = (*DATASTRCH*)
record
NEXTPTR : AN_OPNDXWORDREC;
XWORDPTR : AN_OPERANDXWORD;
end(*OPNDXWORDREC*);
OPND2REC = (*DATASTRCH*)
record
NEXTPTR : AN_OPND2REC;
OPND2IPTR : AN_INSTREC;
end(*OPND2REC*);
CODELIST = (*linked via NEXTPTR*)
record
NWORDS : 0..MAXCODEW;
FIRST, LAST : A_CODEREC;
end (*CODELIST*);
INSTLIST = (*DATASTRCH*)
record
NWORDS : integer; (*sum over all IWDS*)
FIRST, LAST : AN_INSTREC
end (*INSTLIST*); (*DATASTRCH*)
JUMPLIST =
record
NWORDS : 0..MAXCODEW;
FIRST, LAST : AN_INSTREC; (*DATASTRCH*)
end (*JUMPLIST*);
OPNDXWORDFIXLIST = (*DATASTRCH*)
record
NWORDS : integer;
FIRST, LAST : AN_OPNDXWORDREC;
end(*OPNDXWORDFIXLIST*);
OPND2FIXLIST = (*DATASTRCH*)
record
NWORDS : integer;
FIRST, LAST : AN_OPND2REC;
end(*OPND2FIXLIST*);
RTSTACK = (*peg 25jul79...*)
record
SIZE : integer;
FIXLIST, NEGFIXLIST : OPND2FIXLIST; (*KYW 9/5 79*)
end (*RTSTACK*); (*...peg 25jul79*)
LBLHASHENT =
record
LBLNUM : LBL_INDEX;
NEXTPTR : A_LBLHASHENT;
DEFINED : boolean;
BRANCH_CNT : integer; (* peg 02jul79 *)
case LINTVAL_OR_LINSTPTR of
LINTVAL : (INTVAL : integer; CLIST : OPND2FIXLIST); (*DATASTRCH*)
LINSTPTR : (INSTPTR : AN_INSTREC; JLIST : JUMPLIST;
JUMPTABLELABEL : boolean) (*DATASTRCH*)
end (*LBLHASHENT*);
PROCENT =
record
NAME : ALFA;
FIXLIST : OPNDXWORDFIXLIST; (*DATASTRCH*)
NEXTPTR : A_PROCENT
end (*PROCENT*);
PROCSPEC = (* peg 18jul79...*)
record
PROCTYPE : OPNDTYPE;
PROCNAM : NAMEREC;
PARMS_POPPED,
RESULTS_PUSHED,
REGPARMAREA, (* in quarterwords *)
R_MEMORY_AREA, (* in bits...*)
M_MEMORY_AREA : (*...in bits *)
integer;
end (*PROCSPEC*); (*...peg 18jul79 *)
MSTENTRY =
record
DESTLEV : 1..MAXLVL; (*level of callee*)
CURPARMREGS : NUMBER_OF_PAREGS;
(*number of parmregs used by caller*)
EVALSAVESTART : integer;
(*displacement into the evalsave of the
low end of the section used by this call*)
MSTCODESTART : AN_INSTREC; (*Start of code from MST
(NEWINSTREC at entry to PMST)*) (*DATASTRCH*)
end (*MSTENTRY*);
OPERANDXWORD = (*packing tuned for PDP-10 2SEP79 PTZ*)
packed record
case FMT : XW_EV_OR_XW_C of
XW_EV : (P, V, D, I : BIT;
S : 0..MAXINDEXSHIFT;
REG : S1REGISTER;
ADDR : S1ADDRESS;
DISP : S1DISP );
XW_C : (VAL : S1WORD)
end (*OPERANDXWORD*);
OPERAND = (*could be 5 wds if packed, now 8 - 2SEP79 PTZ*)
record
FIXPTR : A_PROCENT; (*used only for XTRNSYMFIX*)
FIXUP : (NOFIX, STRINGFIX, SETFIX, REALFIX,
XTRNSYMFIX, BOUNDFIX);
X : BIT;
REG : S1REGISTER;
F : MINSHORTOFFSET..MAXSHORTOFFSET;
XW : OPERANDXWORD;
end (*OPERAND*);
LVLDSP =
record
DSPLMT : integer;
LVL : 0..MAXLVL
end (*LVLDSP*);
MEMOREG =
record
case WHICH : BANK of
RGS : (RGADR : S1REGISTER);
MEM : (MEMADR : LVLDSP)
end (*MEMOREG*);
VPAREC =
record
VSHIFT : SFLDRNG; (*amount to shift part after
evaluation and indirection.*)
VPAIND : IND1..IND2; (*indirection on this variable part.*)
VPA : MEMOREG; (*memory or register location.*)
end (*VPAREC*);
(*Type DATUM is the crux of this program. It represents a quantity on
the P-Machine stack during the process of executing the P-Code program
being translated. This quantity can be constant, in which case we have
its value in the datum; it may be a variable, in which case we have its
address in register or memory; or it may be a computed value, in which
case we may have the address of a temporary register containing the
quantity, or we may have several of any of the above along with other
information which all together tells what computation is needed beyond
the code which has already been emitted in order to calculate the
quantity.
The process of evaluating a datum can be described as follows. A
'MEMOREG' represents a register or memory address in the S1. Unless
indirected, the quantity represented is that address; thus the value of
a FPA with LVL=1 and DSPLMT=100 is the *address* of the 100th unit after
the unit addressed by the level 1 display register. We consider this a
constant even though it clearly depends on the run-time value of a
register.
If the MEMOREG is in a VPA, more may be done to it. A VPA has an
indirection associated with it of either 1 or 2. A VPA MEMOREG with
indirection 1 represents the quantity at the address described by the
MEMOREG. If the indirection is 2, the MEMOREG describes an address
where there is another address. The contents of the location at that
second address is the value of the quantity. After the appropriate
indirection is done, there may be a shift applied to the quantity (e.g.
if it is to be an index). Note that such a shift is applied after the
VPA indirection.
After the FPA and any active VPAs have been completely evaluated, we add
together their values and indirect the sum 0, 1, or 2 more times to get
the value of the datum itself. Thus for example if FINALIND is 0 the
datum value is the sum of the part values; if FINALIND is 1 the sum is
the *address* of the datum value. *)
DATUM =
record
CODESTART : AN_INSTREC; (*pointer to first S1 instruction
in the evaluation of this datum*) (*DATASTRCH*)
DTYPE : OPNDTYPE;
DLENGTH : DTYPE_LENGTH; (*bit length of item*)
MTYPE : MEMTYPE;
(*The following five fields only apply to booleans.*)
BREPRES : (BINTVAL, BJUMP);
(*tells whether boolean is represented
as a 0..1 value or as jump structure*)
BTRUELIST : JUMPLIST; (*list of jumps that are taken if the
datum is discovered to be true*)
BFALSELIST : JUMPLIST; (*list of jumps that are taken if the
datum is discovered to be false*)
BFALLTHRUSKIPLOC : AN_INSTREC; (*DATASTRCH*)
(*loc of last skip around jump in
code to evaluate boolean*)
BJUMPON : boolean; (*truth value for datum on which the
jump after the fallthruskip jumps*)
(*End of special boolean fields.*)
SCNST : SETREP; (*set value if set constant*)
RCNST : real; (*real value if real constant*)
FINALIND : IND0..IND2;
(*Final indirection depth of represented quantity.
IND0 : constant or constant wrt base.
IND1 : one indirection applied after evaluation.
IND2 : two indirections applied after evaluation.
FINALIND *must* be IND0 if there is no VPA
or if there is no FPA and only one VPA and that VPA
is at indirection IND1. That is, an indirection
applied to an FPA is recorded by making it a VPA,
and an indirection applied to a single VPA with
small internal indirection is recorded by increasing
that internal indirection.*)
FPA : MEMOREG; (*accumulated additive fixed part*)
NVPAS : 0..2; (*number of active VPAs. If only 1,
VPA1 is the active one.*)
VPA1 : VPAREC; (*variable parts : contents of the*)
VPA2 : VPAREC; (*described register or memory loc.*)
end (*DATUM*);
var
(*%IFT D10*)
PRR : text;
(*%ENDC*)
OPC : U_OPCODE;
MNEM : CHAR4;
TYP : OPNDTYPE;
TYPO2 : OPNDTYPE;
MTYP: MEMTYPE;
I1, I2, I3, I4, I5, I6, I7 : integer; (*20JUL79 PTZ*)
R1 : real;
P1 : SETREP;
NAM0, NAM1, NAM2 : NAMEREC;
SVAL : STRINGTYPE;
SLGTH : STRINX;
CLEN : 0..COMMLEN; (*peg 24aug79*)
COMMFIELD : CHAR64; (*peg 24aug79*)
UNKT : boolean; (* To allow unknown UNK instructions *)
SP_EXCESS, (*SETPARMKLUDGE*)
PWORDCOUNT, (* als/peg 17jul79 *)
PSTRCOUNT : NONNEGINT; (* als/peg 13jul79 *)
PREGS_ARCHIVED : boolean; (* als/peg 18jul79 *)
TR_UCODE, TR_S1CODE, TR_SIMP, TR_PEEPHOLE, (*14JAN79 PTZ*)
TR_STACK, TR_MST %, TR_NEST\ : boolean; (* peg 18jul79 *)
OLDINSTREC : AN_INSTREC; (*DATASTRCH*)
OLDTOP : STKINX;
OLDMSTTOP : 0..MAXMST;
UNKNOWN_LOC : integer;
ASM : boolean;
DEBUG : boolean;
NO_JMPX_TO_JMPA_FLG : boolean; (*14JAN79 PTZ...*)
NO_COLLAPSE_MOV_FLG : boolean;
NO_SKIP_JMPA_FLG : boolean; (*...14JAN79 PTZ*)
NO_INC_SKP_FLG : boolean; (*28JUN79 PTZ*)
ASSERTCOUNT : integer;
CURPC : integer;
MAINCODE : INSTLIST; (*DATASTRCH*)
NEWINSTREC : AN_INSTREC; (*DATASTRCH*)
ERRINT1 : integer;
STRINGAREA : CODELIST;
NXTSTRDISP : integer;
STRINGAR_CPTR : A_CODEREC;
REALTBL, SETTBL, LOCTBL, BOUNDTBL : CODELIST;
STRINGFIXLIST, REALFIXLIST, SETFIXLIST : OPNDXWORDFIXLIST; (*DATASTRCH*)
BOUNDFIXLIST : OPNDXWORDFIXLIST; (*DATASTRCH*)
NEG_SHIFT_FIXLIST : OPND2FIXLIST; (*DATASTRCH*)
(*Instructions on this list have OPND2s whose XW displacement
needs to be negated and shifted left at gen-segment time.*)
STACKFRAME : RTSTACK; (*als/peg 25jul79*)
EVALSAVE : RTSTACK;
PROCTBL : record
NPROCS : integer;
FIRST : A_PROCENT
end (*PROCTBL*);
LBLHASHTAB : array [RNG_0_LBLHTSIZEM1] of A_LBLHASHENT;
CSPHASHTAB : array [0..CSPHTSIZEM1] of
record
CSPNAM : NAMEREC;
CSP : P_STANDARDPROC
end (*CSPHASHTAB*);
OPCHASHTAB : array [0..OPCHTSIZEM1] of
record
OPCNAM : CHAR4;
OPC : U_OPCODE
end (*OPCHASHTAB*);
FIRSTTYPE, LASTTYPE : OPNDTYPE;
FIRSTMTYPE, LASTMTYPE, DEFAULTMTYPE : MEMTYPE;
FIRSTS1OP, LASTS1OP : S1OPCODE;
FIRSTSKIP, LASTSKIP : S1OPCODE;
ZERO_OP, EXTENDED_ZERO_OP : OPERAND; (*specify constant 0*)
EMPTY_OP : OPERAND; (*initted to valid but indeterminate value*)
UNUSED_OP : OPERAND; (*specify R0 for unused operands*)
ZEROS1WORD : S1WORD;
ZEROFPA : MEMOREG;
ZEROVPA : VPAREC;
ZERODATUM : DATUM;
EMPTYCODELIST : CODELIST;
EMPTYINSTLIST : INSTLIST; (*DATASTRCH*)
EMPTYOPND2FIXLIST : OPND2FIXLIST; (*DATASTRCH*)
EMPTYOPNDXWORDFIXLIST : OPNDXWORDFIXLIST; (*DATASTRCH*)
EMPTYJUMPLIST : JUMPLIST;
OPNDRTB : OPERAND; (*specifies RTB*)
OPNDRSP : OPERAND; (*specifies the SP*)
SEG_EP_RELPC : integer; (*constant SEG_START_RELPC+SEG_EP_DISP*)
NULL_SET : SETREP; (*for empty-set comparison/assign.*) (*setch*)
WHICHPART : SETPART_INDEX; (*for getting a particular piece of a
constant set out of the set table*)(*setch*)
TWOEXP : array [0..MAX_EXP_ON_COMP_MACH] of integer;
CURPROG : NAMEREC;
CURPROC, MAXTMPPROC : ALFA;
CURPLOC, MAXTMPPLOC : integer;
CURLVL, MAXLVLUSED : 0..MAXLVL;
CURPROCXN : NAMEREC;
DISPLAY : S1REGISTER;
OLDNP : AN_INSTREC; (*saves heap top pointer so space can be
reclaimed after generation of segment*)(*DATASTRCH*)
HARDOPCODE : array [S1OPCODE] of HARDS1OPCODE;
SOFTOPCODE : array [HARDS1OPCODE] of S1OPCODE;
REVERSE_OP : array [S1OPCODE] of S1OPCODE;
INVERSE_SKIP : array [S1SKIPOPCODE] of S1OPCODE; (*28JUN79 PTZ*)
ISKPJMPA_OPCODE : array [S1OPCODE] of S1OPCODE; (*28JUN79 PTZ*)
DSKPJMPA_OPCODE : array [S1OPCODE] of S1OPCODE; (*28JUN79 PTZ*)
OPFORMAT : array [S1OPCODE] of S1OPFORMAT;
S1MNEM : array [S1OPCODE] of CHAR15;
DEST_PRECISION : array [S1OPCODE] of S1PRECISION; (*PTZ*)
COLLAPSIBLE_OP : array [S1OPCODE] of boolean; (*PBK*)
(* indication of whether an XOP or TOP can be collapsed with a
following MOV*) (*PBK*)
TYPECODE : array [OPNDTYPE] of char;
MTYPECODE : array [MEMTYPE] of char;
ALIGNBNDRY : array [OPNDTYPE] of ALIGNMENTBOUNDARY;
S1SIZE : array [OPNDTYPE] of S1Q..S1D;
FUNCUNITS : array [OPNDTYPE] of S1LENGTH;
IS_DOUBLE : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_SINGLE : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_INTEGER : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_REAL : OPNDTYPE_TO_BOOLEAN_ARRAY;
IS_SIGNED_NUM : OPNDTYPE_TO_BOOLEAN_ARRAY;
SKP_NON_X : array [OPNDTYPE] of S1OPCODE;
MOV_X_X : array [OPNDTYPE] of S1OPCODE;
ABS_X : array [OPNDTYPE] of S1OPCODE;
NEG_X : array [OPNDTYPE] of S1OPCODE;
MOVMQ_N : array [1..MAXMOVMQ] of S1OPCODE;
MOVMS_N : array [1..MAXMOVMS] of S1OPCODE; (*5DEC78 ALS*)
FLOAT_S_X : array [OPNDTYPE] of S1OPCODE;
SLR_N : array [S1REGISTER] of S1OPCODE;
SLRADR_N : array [S1REGISTER] of S1OPCODE;
BTRP_B_X : array [OPNDTYPE] of S1OPCODE;
BTRP_N_X : array [0..1, OPNDTYPE] of S1OPCODE;
MOV_X_Y : array [OPNDTYPE, OPNDTYPE] of S1OPCODE;
ARITH_RESULT_TYPE : array [OPNDTYPE, OPNDTYPE] of OPNDTYPE;
COMPARE_COERCE_TYPE : array [OPNDTYPE, OPNDTYPE] of OPNDTYPE;
REAL_ARITH_OP : array [S1S..S1D, UADD..UDIV] of S1OPCODE;
COMPARE_OP : array [S1Q..S1D, UEQU..ULES] of S1OPCODE;
BLKCMP_X_Q : array [UEQU..ULES] of S1OPCODE;
RISFREE : array [S1REGISTER] of boolean;
RPWORD : array [S1REGISTER] of
(RSINGLE, R1STOFPAIR, R2NDOFPAIR, R1STOFBLOCK, RINBLOCK);(*PBK*)(*PEG*)
GISFREE : array [S1GBL] of boolean;
NXTRG : S1REGISTER;
MINTMPS1REG, MAXTMPS1REG, MINDSPS1REG : S1REGISTER;
RTBUSER : STKINX; (*stack index for datum using RTB*)
RTBDOUB : boolean; (*true iff RTBUSER is a doubleword quantity*)
LVL_TO_S1REG : array [1..MAXLVL] of S1REGISTER;
PRM_TO_S1REG : array [0..MAXPAREGM1] of S1REGISTER;
S1REG_TO_PRM : array [S1REGISTER] of integer;
ZSEGTYPE_TO_CHARS : array [ZSEGTYPE] of CHAR4;
ZESDTYPE_TO_CHARS : array [ZESDTYPE] of CHAR4;
ZESRTYPE_TO_CHARS : array [ZESRTYPE] of CHAR4;
ZIXFLAG_TO_CHAR : array [ZESDESRSEG] of char;
ZOPR_TO_CHARS : array [ZOPR] of CHAR2;
LOCALSIZELNUM : LBL_INDEX;
ALL_CODE_EMITTED : boolean; (*DATASTRCH*)
JUMPS_CONCRETIZED : boolean;
JUMPTABLE_IN_PROGRESS : boolean;
STK : array [STKINX] of DATUM;
BOT, TOP : STKINX; (*BOT changed to var -- peg 09jul79*)
STKFRAME : array [FRAMEINX] of STKINX; (* peg 09jul79 *)
CURFRAME : FRAMEINX; (* peg 09jul79 *)
MSTSTK : array [0..MAXMST] of MSTENTRY;
MSTTOP : 0..MAXMST;
BLOCKTABLE : array [MINBLOCK..MAXBLOCK] of ILLBLOCKNO..MAXLVL;
CURPROCSPEC : PROCSPEC; (* peg 18jul79 *)
TIMER : integer;
ERRORCNT : NONNEGINT;
S1OP_CNT : array [S1OPCODE] of integer; (*LCW*)
S1OP_TOT : integer; (*LCW*)
S1OP : S1OPCODE; (*LCW*)
WORD_CNT : integer; (*LCW*)
PEEP_PASSES : integer; (*PTZ*)
INSTR_WDS_REMOVED : integer; (*PTZ*)
J_TO_J_CNT : integer; (*PBK*)
JMPAS_REMOVED_FROM_SKIPS : integer; (*PTZ*)
MOV_COLLAPSE : array [1..14] of integer; (*21JUN79 PTZ*)
MOVS_COLLAPSED : integer; (*PTZ*)
INC_SKP_COLLAPSE : array [1..3] of integer; (*29JUN79 PTZ*)
INC_SKPS_COLLAPSED : integer; (*2JUL79 PTZ*)
ICNT : integer; (*21JUN79 PTZ*)
S1INSTBUF : array [INSTBUFINX] of S1WORD; (*DATASTRCH*)
TOTAL_STORAGE : integer; (*31AUG79 PTZ...*)
NUM_PROCS_COMPILED : integer;
MAX_STORAGE : integer; (*...31AUG79 PTZ*)
ICUPSEEN : boolean;
PSWITCHNAME : alfa;
(** ERROR_CLASS: ERREXIT ASSERTFAIL ERROR **)
(**)
function FLDW(NUM : integer) : integer;
forward;
procedure ERREXIT (CODE : integer);
begin
WRITELN(OUTPUT,'** * ERREXIT called with code =',CODE);
(*%IFT D10*)
HALT
(*%ELSE*)
% EXIT(4097) \
(*%ENDC*)
end;
procedure ASSERTFAIL(MSG : CHAR12); (* ALS*)
(*ASSERTFAIL is used for internal consistency checking of the program.
The BOOLEAN that is a parameter in the ASSERT calls is here tested
before calling ASSERTFAIL, to avoid needless procedure calls.
The message in MSG is printed (to identify the particular
assertion) togather with an assertion count (now only a count of
the failed assertions) and execution is terminated. Note, that as it
is, only one failure will be reported. By not EXITTing one might get
more information from an attempted compilation.*)
begin
ASSERTCOUNT := ASSERTCOUNT + 1;
WRITELN(OUTPUT);
WRITELN(OUTPUT);
WRITELN(OUTPUT,'** ** ERROR ** ** Assertion #',ASSERTCOUNT:6,
' failed : ',MSG,' ** **');
(* ASSERTCOUNT := ASSERTCOUNT div (ASSERTCOUNT-ASSERTCOUNT); 17JAN79 EJG*)
ERREXIT(9999)
end (*ASSERTFAIL*);
procedure ERROR(CODE : ERRORCODE);
(*This procedure is called whenever an error condition is detected
in the input U-Code. At the very least, it prints a message
describing the error. For the time being, it then gives up the
ghost and halts execution.*)
begin
ERRORCNT := ERRORCNT + 1;
WRITE(OUTPUT,' *ERROR* ');
case CODE of
WARITH_ON_WRONG_DT :
begin
WRITELN(OUTPUT,'Arith on wrong data type')
end;
WNOT_IMPLEMENTED :
begin
WRITELN(OUTPUT,'Not yet implemented') (*pn*)
end;
WILLEGAL_LABEL :
begin
WRITELN(OUTPUT,'Illegal label number or format')
end;
WABS_OR_NEG_OF_NONSIGNED :
begin
WRITELN(OUTPUT,'ABS or NEG applied to non-signed number')
end;
WADDR_OUT_OF_RANGE :
begin
WRITELN(OUTPUT,
'Fixed-up address exceeds 30-bit S1 address space')
end;
WADDRESS_CHECK_ON_NONADDRESS :
begin
WRITELN(OUTPUT,'CHK type A applied to non-address')
end;
WALIGNMENT_ERROR :
begin
WRITELN(OUTPUT,'Alignment error')
end;
WANDOR_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'AND or IOR applied to non-boolean')
end;
WBGN_STP_NAME_MISMATCH :
begin
WRITELN(OUTPUT,
'Name parameters of BGN and STP do not match')
end;
WENT_AND_PLOD_INCONSISTENT :
begin
WRITELN(OUTPUT,
'Type parameters of ENT and PLOD do not match')
end;
WENT_END_NAME_MISMATCH :
begin
WRITELN(OUTPUT,
'Name parameters of ENT and END do not match')
end;
WENT_SPECIFIED_WRONG_PARMS :
begin
WRITELN(OUTPUT,
'ENT specified wrong number of parameters')
end;
WBINARY_OPND_TYPE_CONFLICT :
begin
WRITELN(OUTPUT,
'Invalid or conflicting operand types for binary operation')
end;
WBOOL_IS_TRUE :
begin
WRITELN(OUTPUT, 'CHKF: Boolean found to be not false')
end;
WBOOL_NOT_TRUE :
begin
WRITELN(OUTPUT, 'CHKT: Boolean found to be not true')
end;
WCHECKED_CONSTANT_OUT_OF_RANGE :
begin
WRITELN(OUTPUT,
'CHK constant operand out of specified range')
end;
WCHKF_CHKT_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'CHKF or CHKT needs boolean')
end;
WCHKN_NULL_TOP :
begin
WRITELN(OUTPUT,'CHKN Top of stack is the nil pointer')
end;
WCHKN_NOT_ADDRESS :
begin
WRITELN(OUTPUT,'CHKN Top of stack not an address')
end;
WCHECKING_INVALID_TYPE :
begin
WRITELN(OUTPUT,'CHK applied to invalid operand type')
end;
WCHR_NEEDS_INT :
begin
WRITELN(OUTPUT,'CHR applied to non-integer')
end;
WCOERCION_INVALID :
begin
WRITELN(OUTPUT,'Invalid type coercion')
end;
WCOMPARE_ILLEGAL :
begin
WRITELN(OUTPUT,
'Invalid or conflicting operand types for compare operation')
end;
WCOMPM_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'Compare type M applied to non-address')
end;
WCONST_OUT_OF_RANGE_FOR_SET :
begin
WRITELN(OUTPUT,'Constant is out of range for set')
end;
WDISP_OUT_OF_RANGE :
begin
WRITELN(OUTPUT,
'Fixed-up displacement exceeds 25 bit S1 limit')
end;
WDUP_ON_EMPTY_STACK :
begin
WRITELN(OUTPUT,'DUP with empty stack')
end;
WEQU_etc_with_TYP_is_TYPM :
begin
WRITELN(OUTPUT,'EQU..NEQ with TYP=TYPUM in UCODE')
end;
WEXPR_TOO_COMPLEX :
begin
WRITELN(OUTPUT,
'Expression too complex (or total proc nesting too deep)')
end;
WFILE_ADDRESS_NEEDED :
begin
WRITELN(OUTPUT,'Stack top must be file address')
end;
WTJP_FJP_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'TJP or FJP with non-boolean stack top')
end;
WTJP_FJP_WITH_NONEMPTY_STACK :
begin
WRITELN(OUTPUT,'TJP or FJP with non-singleton expr stack')
end;
WFIX_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,'RND applied to invalid operand type')
end;
WFLOAT_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,
'FLO or FLT applied to invalid operand type')
end;
WFUNC_CALLS_NESTED_TOO_DEEPLY :
begin
WRITELN(OUTPUT,
'Function calls nested too deeply in expression')
end;
WIEQU_etc_with_TYP_not_TYPM :
begin
WRITELN(OUTPUT,'IEQU..INEQ with TYP<>TYPUM in UCODE')
end;
WILLEGAL_PROC_TYPECODE :
begin
WRITELN(OUTPUT,
'Invalid procedure type in U-Code instruction')
end;
WINCOMPATIBLE_TYPES :
begin
WRITELN(OUTPUT,'Incompatible types for storing')
end;
WINDEX_WITHOUT_BASE :
begin
WRITELN(OUTPUT,'IND on (shifted) index without base')
end;
WINDEXING_IN_PARMS :
begin
WRITELN(OUTPUT,
'Indexing within fast (register) parameter area')
end;
WINN_REQUIRES_SET_ON_TOP_OF_STACK :
begin
WRITELN(OUTPUT,'INN on non-set second operand')
end;
WINSTR_TYPE_NOT_DATUM_TYPE :
begin
WRITELN(OUTPUT, 'Type in U-Code command different',
' from type of stack top.')
end;
WINSUFF_PARMS_SPECIFIED :
begin
WRITELN(OUTPUT,
'CUP specified fewer parameters than are on stack')
end;
W2_MANY_PARMS_SPECIFIED :
begin
WRITELN(OUTPUT,
'CUP specified more parameters than are on stack')
end;
WINTEGER_CONSTANT_DIV_MOD_BY_ZERO :
begin
WRITELN(OUTPUT,'DVI or mod by integer constant zero')
end;
WINVAL_BLOCK_NUMBER :
begin
WRITELN(OUTPUT, 'Invalid memory block number')
end;
WINVAL_CSP :
begin
WRITELN(OUTPUT, 'Invalid standard procedure name')
end;
WINVAL_OPC :
begin
WRITELN(OUTPUT, 'Invalid U-Code opcode:',MNEM)
end;
WINVAL_TRACE :
begin
WRITELN(OUTPUT, 'Invalid trace argument')
end;
WINVAL_U_TYPECODE :
begin
WRITELN(OUTPUT, 'Invalid type in U-Code instruction')
end;
WINVAL_TYP_ON_LDC :
begin
WRITELN(OUTPUT,'LDC type argument invalid')
end;
WINVALID_DISPLACEMENT :
begin
WRITELN(OUTPUT,
'Fixed-up displacement exceeds 25 bit S1 limit')
end;
WINVALID_TYPE_COERCION :
begin
WRITELN(OUTPUT,'Invalid type coercion')
end;
WINVALID_LEVEL :
begin
WRITELN(OUTPUT, 'Invalid level in U-Code instruction')
end;
WINVALID_MEMORY_TYPE :
begin
WRITELN(OUTPUT, 'Invalid memory type in U-Code instruction')
end;
WIXA_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'IXA on non-address first operand')
end;
WLAST_SST_PARM_TOO_BIG :
begin
WRITELN(OUTPUT, 'Last SST parameter bigger than MAXPAREG')
end;
WL_LPTR_LBLNUM_UNDEFINED :
begin
WRITELN(OUTPUT,
'Undefined label : L',ERRINT1:FLDW(ERRINT1))
end;
WLOADING_STRING :
begin
WRITELN(OUTPUT,
'IND loading string (indirect thru string constant illegal)')
end;
WISTR_INST_NEEDS_ADDRS :
begin
WRITELN(OUTPUT,'ISTR or INST with non-address operand')
end;
WMOV_NEEDS_ADDRS :
begin
WRITELN(OUTPUT,'MOV with non-address operand(s)')
end;
WMST_SPECIFIED_INSUFF_PARM_STORAGE :
begin
WRITELN(OUTPUT,
'MST specified insufficient parameter storage')
end;
WMST_WITHOUT_CUP_IN_LAST_SEGMENT :
begin
WRITELN(OUTPUT,
'MST without corresponding CUP in last segment')
end;
WMULT_DEFINED_LAB :
begin
WRITELN(OUTPUT,'Multiply defined label')
end;
WNESTING_TOO_DEEP_OR_EXPRESSION_TOO_COMPLEX :
begin
WRITELN(OUTPUT,
'Total proc nesting too deep (or some expr too complex)')
end;
WNEW_MUST_HAVE_ADDR_AND_INT :
begin
WRITELN(OUTPUT,
'NEW operands not (1) address and (2) integer')
end;
WNOT_AN_ADDR :
begin
WRITELN(OUTPUT,'ILOD applied to non-address type')
end;
WNOT_DISCRETE_TYPE :
begin
WRITELN(OUTPUT,
'INC, DEC, PRE, or SUC applied to non-discrete type')
end;
WNOT_NEEDS_BOOLEAN :
begin
WRITELN(OUTPUT,'NOT applied to non-boolean')
end;
WNULLREF :
begin
WRITELN(OUTPUT,'IND applied to nil')
end;
WODD_REQUIRES_AN_INTEGER :
begin
WRITELN(OUTPUT,'ODD applied to non-integer')
end;
WORD_NEEDS_INT_BOOLEAN_OR_CHAR :
begin
WRITELN(OUTPUT,
'ORD operand not integer, boolean, or char')
end;
WPOP_OF_EMPTY_STACK :
begin
WRITELN(OUTPUT,
'Pop of empty expr stack (stack underflow)')
end;
WREAL_CONSTANT_DIVISION_BY_ZERO :
begin
WRITELN(OUTPUT,'DVR by real constant zero')
end;
WREGPARMS_SPEC_TOO_LOW_IN_MST :
begin
WRITELN(OUTPUT,
'MST specified insufficient register parameter storage')
end;
WROUND_OF_NON_REAL : (*ROUND...*)
begin
WRITELN(OUTPUT,'Round of non-real quantity')
end; (*...ROUND*)
WRST_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'RST operand not address')
end;
WSAV_NEEDS_ADDR :
begin
WRITELN(OUTPUT,'SAV operand not address')
end;
WSET_OPERATION_ON_NONSET_TYPES :
begin
WRITELN(OUTPUT,'Set operation applied to non-set')
end;
WSGS_OR_INN_REQUIRES_INT_CHAR_OR_BOOLEAN :
begin
WRITELN(OUTPUT,
'SGS or INN (first) operand not integer, boolean, or char')
end;
WSIO_DIDNT_SEE_FILEADDR :
begin
WRITELN(OUTPUT,'SIO didnt see file addr')
end;
WSIO_WITH_NONADDRESS :
begin
WRITELN(OUTPUT,'SIO operand not address')
end;
WSQUARE_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,'SQR operand type invalid')
end;
WSTACK_LEFT_NONEMPTY_IN_LAST_SEGMENT :
begin
WRITELN(OUTPUT,'Expr stack left nonempty in last segment')
end;
WSTACK_NON_EMPTY :
begin
WRITELN(OUTPUT, 'Expression stack should have been ',
'empty after last instruction')
end;
WSTACK_NOT_SINGLE :
begin
WRITELN(OUTPUT, 'Expression stack should have ',
'contained exactly one element ',
'after last instruction')
end;
WSWP_NOT_2 :
begin
WRITELN(OUTPUT,'SWP with less than 2 DATUMs on STACK')
end;
WSWP_TYP_ERROR :
begin
WRITELN(OUTPUT,'SWP operand types specified incorrectly')
end;
W2_MANY_BGNBS :
begin
WRITELN(OUTPUT,
'Too many BGNB instructions encountered: stack overflow')
end;
W2_MANY_ENDBS :
begin
WRITELN(OUTPUT,
'Too many ENDB instructions encountered: stack underflow')
end;
WTOO_LARGE_K_OR_L :
begin
WRITELN (OUTPUT,'Too large non-neg. integer')
end;
WTRUNCATE_OF_INVALID_TYPE :
begin
WRITELN(OUTPUT,'TRC operand type invalid')
end;
WCVT_WITH_INVALID :
begin
WRITELN(OUTPUT,'CVT or CVT2 instruction with invalid dtype')
end;
WTYP_WITH_INVALID :
begin
WRITELN(OUTPUT,'TYP or TYP2 instruction with invalid dtype')
end;
WUJP_WITH_NONEMPTY_STACK :
begin
WRITELN(OUTPUT,'UJP with nonempty expr stack')
end;
WWRONG_COMPARE :
begin
WRITELN(OUTPUT,
'Wrong compare operator for given operand types')
end;
WWRONG_INSTR_DATATYPE :
begin
WRITELN(OUTPUT,
'Invalid data type for this instruction')
end;
WWRONG_RESULT_NUMBER :
begin
WRITELN(OUTPUT,
'CUP instruction specified wrong number of function',
' results--(no value-result parmeters allowed');
end;
WXJP_WITHOUT_SINGLETON_STACK :
begin
WRITELN(OUTPUT,'XJP with non-singleton expr stack')
end
end (*case*);
if not (FALSE) then
ASSERTFAIL('ERROR 999'); (*temporary to get traceback*)
ERREXIT(1000) (*Basic giving-up-the-ghost action.*)
end (*ERROR*);
(** DEBUGGING_CLASS: PRINTSET PRINTMEMOREG PRINTDATUM PRINT_NESTITEM PRINT_MSTENTRY PRINTNXTINST PRINTNAM PRINTTYP PRINTMTYP PRINTINT **)
(**)
function IS_CONSTANT (STE : STKINX) : boolean;
forward;
procedure DISASSEMBLE(var CURPC : integer; IPTR : AN_INSTREC);(*DATASTRCH*)
forward;
function SET_IN(SET_EL : SET_EL_TYP; PSET : SETREP) : boolean;
forward;
procedure PRINTSET (S : SETREP);
(*Print the set.*)
var I : SET_EL_TYP; (*setch*)
COUNT : integer;
begin
WRITE (OUTPUT, ' [');
COUNT := 0;
for I := 0 to SET_MAX do
if SET_IN(I,S) then (*setch*)
begin
if COUNT > 15 then (*setch*)
begin
WRITELN(OUTPUT);
WRITE (OUTPUT, ' ');
COUNT := 0;
end;
WRITE (OUTPUT, I : 4);
COUNT := COUNT + 1;
end;
WRITELN (OUTPUT, '].');
end (*PRINTSET*);
procedure PRINTSTRING(var STRVAL : STRINGTYPE; var STRLGTH : STRINX);
(*Print a string from STRVAL -- als/peg 24jul7.*)
var I : STRINX;
begin
for I := 1 to STRLGTH do
WRITE (OUTPUT, STRVAL[I]);
end (*PRINTSTRING*);
procedure PRINTSCONST(var STRVAL : STRINGTYPE; var STRLGTH : STRINX);
(*Print a string from STRVAL as a quoted string constant -- PN *)
var I : STRINX;
begin
WRITE (OUTPUT,' ''');
for I := 1 to STRLGTH do
begin
WRITE (OUTPUT, STRVAL[I]);
if STRVAL[I] = '''' then WRITE (OUTPUT, STRVAL[I]);
end;
WRITE (OUTPUT,'''');
end (*PRINTSTRING*);
procedure PRINTMEMOREG (var X : MEMOREG);
(*Print the memoreg without changing lines.*)
begin
if X.WHICH = RGS then
begin
if X.RGADR = S1RTA then
WRITE (OUTPUT, 'RTA')
else if X.RGADR = S1RTB then
WRITE (OUTPUT, 'RTB')
else
WRITE (OUTPUT, 'R', ord(X.RGADR) : FLDW(ord(X.RGADR)) )
end
else if X.MEMADR.LVL = 0 then
WRITE (OUTPUT, X.MEMADR.DSPLMT : FLDW(X.MEMADR.DSPLMT) )
else
WRITE (OUTPUT, '<L', X.MEMADR.LVL : FLDW(X.MEMADR.LVL),
',', X.MEMADR.DSPLMT : FLDW(X.MEMADR.DSPLMT), '>' );
end (*PRINTMEMOREG*);
procedure PRINTDATUM (STE : STKINX);
(*Print the datum for trace or debugging purposes.*)
var PTR : AN_INSTREC; (*DATASTRCH*)
I : integer;
UNKNOWN_LOC : integer;
begin
with STK[STE] do
begin
WRITELN (OUTPUT, ' STK[', STE : FLDW(STE), '] IS' );
WRITE (OUTPUT, ' TYP', TYPECODE[DTYPE], ' = ');
if (DTYPE = TYPUR) and IS_CONSTANT(STE) then
WRITELN (OUTPUT, RCNST)
else if (DTYPE = TYPUS) and IS_CONSTANT(STE) then
PRINTSET (SCNST)
else if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
begin
WRITELN (OUTPUT, 'BJUMP with', BTRUELIST.NWORDS : 3,
' true jumps and', BFALSELIST.NWORDS : 3,
' false jumps.' );
WRITE (OUTPUT, ' BJUMPON is ');
if BJUMPON then WRITE (OUTPUT, 'TRUE')
else WRITE (OUTPUT, 'FALSE');
WRITELN (OUTPUT, ' and fall thru skip is');
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, BFALLTHRUSKIPLOC);
PTR := BTRUELIST.FIRST;
for I := 1 to BTRUELIST.NWORDS do
begin
if not ( PTR <> nil) then ASSERTFAIL('PRINTDATU001');
PTR := PTR↑.DESTPTR; (*DATASTRCH*)
end;
PTR := BFALSELIST.FIRST;
for I := 1 to BFALSELIST.NWORDS do
begin
if not ( PTR <> nil) then ASSERTFAIL('PRINTDATU002');
PTR := PTR↑.DESTPTR; (*DATASTRCH*)
end;
end
else
begin
WRITE (OUTPUT, ord(FINALIND) : 1, ': (' );
PRINTMEMOREG (FPA);
if NVPAS > 0 then
begin
WRITE (OUTPUT, ', ', ord(VPA1.VPAIND) : 1, ': (' );
PRINTMEMOREG (VPA1.VPA);
WRITE (OUTPUT, ')*', TWOEXP[VPA1.VSHIFT] : 1 );
end;
if NVPAS = 2 then
begin
WRITE (OUTPUT, ', ', ord(VPA2.VPAIND) : 1, ': (' );
PRINTMEMOREG (VPA2.VPA);
WRITE (OUTPUT, ')*', TWOEXP[VPA2.VSHIFT] : 1 );
end;
WRITELN (OUTPUT, ').' );
end;
WRITE (OUTPUT,
' Code starts with the instruction ');
if CODESTART = NEWINSTREC then
WRITELN (OUTPUT, 'at NEWINSTREC.')
else if CODESTART = nil then
writeln (OUTPUT, '??? NIL pointer.')
else
WRITELN (OUTPUT, S1MNEM[CODESTART↑.OPCODE] ); (*DATASTRCH*)
end (*with*);
end (*PRINTDATUM*);
%procedure PRINT_NESTITEM (INDEX : integer); (*commented out by*)
(*Print NESTDISPLAY[INDEX].*) (* peg 18jul79 *)
begin
with NESTDISPLAY[INDEX] do
begin
WRITELN (OUTPUT, ' NESTDISPLAY[',
INDEX : FLDW(INDEX), '] IS' );
WRITELN (OUTPUT, ' ', PROCNAM.NAM, ' TYP', TYPECODE[PROCTYPE],
' areas ', REGPARMAREA, FIRSTPARMAREA,
L_MEMORY_AREA, M_MEMORY_AREA );
WRITELN (OUTPUT, ' displacements', LCBEFPAR,
OFFSET_IN_VARS, LOCALDATAOFFSET,
LOCALDATATRANSLATION );
end (*with*);
end (*PRINT_NESTITEM*); \(*end comment out*)
procedure PRINT_MSTENTRY (INDEX : integer);
(*Print MSTSTK[INDEX].*)
begin
with MSTSTK[MSTTOP] do
begin
WRITELN (OUTPUT, ' MSTSTK[',
INDEX : FLDW(INDEX), '] is' );
WRITELN (OUTPUT, ' lev', DESTLEV : 2,
', pregs', CURPARMREGS : 3 );
WRITELN (OUTPUT,
' evalsave', EVALSAVESTART : FLDW(EVALSAVESTART));
end (*with*);
end (*PRINT_MSTENTRY*);
procedure PRINTNXTINST;
(*Print next P-Code instruction.*)
var I: integer;
procedure PRINTNAM (var NAM : NAMEREC);
(*Print two spaces and the name.*)
var I : ALFALEN;
begin
WRITE (OUTPUT, ' ');
for I := 1 to NAM.LEN do WRITE (OUTPUT, NAM.NAM[I]);
end (*PRINTNAM*);
procedure PRINTTYP (TYP : OPNDTYPE);
(*Print two blanks and the type code.*)
begin
WRITE (OUTPUT, ' ', TYPECODE[TYP]);
end (*PRINTTYP*);
procedure PRINTMTYP (TYP : MEMTYPE);
(*Print two blanks and the memory type code.*)
begin
WRITE (OUTPUT, ' ', MTYPECODE[TYP]);
end (*PRINTTYP*);
procedure PRINTINT (I : integer);
(*Print two blanks and the integer.*)
begin
WRITE (OUTPUT, ' ', I : FLDW(I));
end (*PRINTINT*);
begin
if (OPC = ULAB) or (OPC = UENT) or (OPC = UCLAB) or (OPC = USYM) then
PRINTNAM (NAM0)
else
WRITE (' ');
WRITE (OUTPUT, ' ', MNEM);
case OPC of
UCHKF, UCHKN, UCHKT, URET :
(*null case*);
UCLAB, ULAB, UMST, UNEW, UPLEX, UTJP :
PRINTINT (I1);
UEXPP, UIMPP, UIMPV :
begin
PRINTINT (I1);
PRINTNAM (NAM1);
end;
ULEX : begin
PRINTINT (I1);
PRINTINT (I2);
end;
ULDP : begin
PRINTINT (I1);
PRINTINT (I2);
PRINTNAM (NAM1);
end;
ULOC : begin
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
PRINTINT (I4);
end;
UEND : PRINTNAM (NAM1);
UBGN, UFJP, UUJP, USTP :
PRINTNAM (NAM1);
UOPTN : begin
PRINTNAM (NAM1);
PRINTINT (I1);
end;
UABS, UADD, USUB, UMPY, UDIV, UAND, UDIF, UDMD, UDSP, UDUP,
UEQU, UNEQ, UGEQ, UGRT, ULEQ, ULES, UIEQU,UINEQ,UIGEQ,UIGRT,
UILEQ,UILES,UINN, UINT, UIOR, UMOD, UMUS, UNEG, UNOT, UODD,
USDEF,USGS, USQR, UUNI :
PRINTTYP (TYP);
UCVT, UCVT2, URND, USWP, UTYP, UTYP2 :
begin
PRINTTYP (TYP);
PRINTTYP (TYPO2);
end;
UDEC, UINC, UIXA, UMOV :
begin
PRINTTYP (TYP);
PRINTINT (I1);
end;
UCHKL, UCHKH :
begin
PRINTTYP (TYP);
if TYP = TYPUC then
PRINTSCONST(SVAL, SLGTH)
else PRINTINT (I1);
end;
UADJ, UICUP, UILOD, UINST, UISTR:
begin
PRINTTYP (TYP);
PRINTINT (I1);
PRINTINT (I2);
end;
UENT : begin
PRINTTYP (TYP);
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
PRINTINT (I4);
end;
UDEF : begin
PRINTMTYP (MTYP);
PRINTINT (I1);
end;
UDEAD, UDOA, UEXPV, ULDA, ULIVE, USYM :
begin
PRINTMTYP (MTYP);
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
end;
UMDEF : begin
PRINTMTYP (MTYP);
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
WRITE (OUTPUT, ' ');
PRINTSTRING (SVAL, SLGTH);
end;
UXJP :
begin
PRINTTYP (TYP);
PRINTNAM (NAM1);
PRINTNAM (NAM2);
PRINTINT (I1);
PRINTINT (I2);
end;
ULOD, UNSTR, UPAR, UPLOD, USTR, UPSTR :
begin
PRINTTYP (TYP);
PRINTMTYP (MTYP);
PRINTINT (I1);
PRINTINT (I2);
PRINTINT (I3);
end;
UCSP : begin
PRINTTYP (TYP);
PRINTNAM (NAM1);
PRINTINT (I1);
PRINTINT (I2);
end;
UCUP : begin
PRINTTYP (TYP);
PRINTINT (I1);
PRINTNAM (NAM1);
PRINTINT (I2);
PRINTINT (I3);
end;
ULDC : begin
PRINTTYP (TYP);
PRINTINT (I1);
case TYP of
TYPUI, TYPUK, TYPUM, TYPUQ :
ERROR(WNOT_IMPLEMENTED);
TYPUB, TYPUJ, TYPUL :
PRINTINT (I2);
TYPUC : PRINTSCONST (SVAL, SLGTH);
TYPUR : WRITE (OUTPUT, ' ', R1);
TYPUN : (*null case*);
TYPUS : PRINTSET (P1);
end (*case TYP of*);
end (*ULDC*);
ULCA : begin
PRINTTYP (TYP);
PRINTINT (I1);
case TYP of
TYPUI, TYPUK, TYPUQ :
ERROR(WNOT_IMPLEMENTED);
TYPUB, TYPUJ, TYPUL :
PRINTINT (I2);
TYPUC : PRINTSCONST (SVAL, SLGTH);
TYPUR : WRITE (OUTPUT, ' ', R1);
TYPUS : PRINTSET (P1);
TYPUM : PRINTSCONST (SVAL, SLGTH);
end (*case TYP of*);
end (*ULCA*);
UCOMM :
begin
WRITE (OUTPUT,' ');
for I := 1 to CLEN do
WRITE(OUTPUT, COMMFIELD[I]);
WRITELN(OUTPUT);
end ;
UUNK : begin
PRINTINT (I2);
PRINTINT (I3);
WRITE (OUTPUT,' ');
PRINTSTRING (SVAL, SLGTH);
end;
end (*case OPC of*);
WRITELN(OUTPUT);
end (*PRINTNXTINST*);
(** SETREP_PROCESSOR_CLASS: SET_IN SET_DIF SET_INT SET_UNI BUILD_SET *)(*setch*)
(**)
(*%IFF SET4*)
function SET_IN(*(SET_EL : SET_EL_TYP; PSET : SETREP) : boolean*);
(* SET_IN performs the function of the set IN operator for the structured
representation of large sets. Its first parameter is the scalar to be
tested for inclusion in the set, which is the second parameter. setch*)
var INDEX : SETREP_INDEX;
begin
INDEX := SET_EL div HOST_SET_SIZE; (*figure which real set to use*)
SET_EL := SET_EL mod HOST_SET_SIZE; (*figure correct offset*)
if SET_EL in PSET[INDEX] then
SET_IN := true
else
SET_IN := false;
end (*SET_IN*);
(* SET_DIF, SET_INT, and SET_UNI perform the functions of set difference,
intersection, and union, respectively, for the structured representation
of large sets. Note that their parameters A, B, and C correspond to the
construct A := B <setop> C . setch*)
procedure SET_DIF(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)
var I : SETREP_INDEX;
begin
for I := 0 to SETREP_MAX do
DESTSET[I] := OP1SET[I] - OP2SET[I];
end (*SET_DIF*);
procedure SET_INT(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)
var I : SETREP_INDEX;
begin
for I := 0 to SETREP_MAX do
DESTSET[I] := OP1SET[I] * OP2SET[I];
end (*SET_INT*);
procedure SET_UNI(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)
var I : SETREP_INDEX;
begin
for I := 0 to SETREP_MAX do
DESTSET[I] := OP1SET[I] + OP2SET[I];
end (*SET_UNI*);
procedure BUILD_SET(var S : SETREP; SET_EL : SET_EL_TYP);
(*Add a scalar to a structured representation of a large set.*) (*setch*)
var INDEX: SETREP_INDEX;
begin
INDEX := SET_EL div HOST_SET_SIZE;
SET_EL := SET_EL mod HOST_SET_SIZE;
S[INDEX] := S[INDEX]+[SET_EL];
end (*BUILD_SET*);
(*%ELSE*)
%\
%function SET_IN(*(SET_EL : SET_EL_TYP; PSET : SETREP) : boolean*);(*setch*)\
% begin\
% SET_IN := SET_EL in PSET\
% end (*SET_IN*);\
%\
%\
%procedure SET_DIF(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)\
% begin\
% DESTSET := OP1SET - OP2SET\
% end (*SET_DIF*);\
%\
%\
%procedure SET_INT(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)\
% begin\
% DESTSET := OP1SET * OP2SET\
% end (*SET_INT*);\
%\
%\
%procedure SET_UNI(var DESTSET : SETREP; OP1SET, OP2SET : SETREP); (*setch*)\
% begin\
% DESTSET := OP1SET + OP2SET\
% end (*SET_UNI*);\
%\
%\
%procedure BUILD_SET(var S : SETREP; SET_EL : SET_EL_TYP); (*setch*)\
% begin\
% S := S + [SET_EL]\
% end (*BUILD_SET*);\
%\
(*%ENDC*)
(** S1WORD_PROCESSOR_CLASS: NEWCODEREC MAKE_NEWINSTREC NEWOPNDXWORDREC NEWOPND2REC GETFIELD GETSIGNEDFIELD PUTFIELD **)
(**)
procedure NEWCODEREC(var X : A_CODEREC);
(*Gets a fresh new CODEREC from the heap.*)
begin
new(X);
X↑.NEXTPTR := nil;
X↑.CODEWORD := ZEROS1WORD
end (*NEWCODEREC*);
procedure MAKE_NEWINSTREC(var X : AN_INSTREC); (*DATASTRCH*)
(*Gets a fresh new INSTREC from the heap. *)
begin
new(X);
with X↑ do
begin
NEXTPTR := nil;
PREVPTR := nil;
IWDS := 0;
with INSTOPND1 do
begin
REG := 0;
F := 0;
XWD := nil;
end(*INSTOPND1*);
with INSTOPND2 do
begin
REG := 0;
F := 0;
XWD := nil;
end(*INSTOPND2*);
end(*X↑*);
end(*MAKE_NEWINSTREC*);
procedure NEWOPNDXWORDREC(var X : AN_OPNDXWORDREC); (*DATASTRCH*)
(*Gets a fresh new OPNDXWORDREC from heap.*)
begin
new(X);
X↑.NEXTPTR := nil;
X↑.XWORDPTR := nil
end (*NEWOPNDXWORDREC*);
procedure NEWOPND2REC(var X : AN_OPND2REC); (*DATASTRCH*)
(*Gets a fresh new OPND2REC from heap.*)
begin
new(X);
X↑.NEXTPTR := nil;
X↑.OPND2IPTR := nil
end (*NEWOPND2REC*);
function GETFIELD (var WORD : S1WORD; STARTBIT : S1BITNUM;
BITLEN : BITFIELD_LENGTH) : integer;
(*Returns in the low-order BITLEN bits of the result the unsigned
value of the field of WORD starting at bit number STARTBIT.
For the present, BITLEN must be <= BITS_ON_COMP_MACH - 1.
Bits are numbered from left to right starting at 0.
Note : this routine changes when S1WORDs really exist!*)
(*%IFT D10*) (*4AUG79 PTZ...*)
extern;
(*%ELSE*)
% external; \
(*%ENDC*) (*...4AUG79 PTZ*)
%************insert assembly versions*************)
var W1, W2 : integer;
FIRSTAFTER : integer;
begin
W1 := WORD.LHALF;
W2 := WORD.RHALF;
FIRSTAFTER := STARTBIT + BITLEN;
if not ((BITLEN <= BITS_ON_COMP_MACH - 1) and
(0<=W1) and (W1<TWOEXP[18]) and
(0<=W2) and (W2<TWOEXP[18])) then ASSERTFAIL('GETFIELD 001');
if STARTBIT <= 17 then
if FIRSTAFTER > 18 then
(*crosses the 'halfword' boundary*)
GETFIELD:=
W1 mod TWOEXP[18-STARTBIT] * TWOEXP[FIRSTAFTER-18]
+ W2 div TWOEXP[36-FIRSTAFTER]
else
(*totally in left halfword*)
GETFIELD := (W1 mod TWOEXP[18-STARTBIT])
div TWOEXP[18-FIRSTAFTER]
else
(*totally in right halfword*)
GETFIELD := (W2 mod TWOEXP[36-STARTBIT])
div TWOEXP[36-FIRSTAFTER];
end (*GETFIELD*);
(*****************end of comment out***************\
function GETSIGNEDFIELD (var WORD : S1WORD;
STARTBIT : S1BITNUM;
BITLEN : BITFIELD_LENGTH) : integer;
(*Do sign-extend on GETFIELD. BITLEN must be <= BITS_ON_COMP_MACH - 1.*)
(*%IFT D10*) (*4AUG79 PTZ...*)
extern;
(*%ELSE*)
% external; \
(*%ENDC*) (*...4AUG79 PTZ*)
%***********insert assembly versions**************)
var T : integer;
begin
if not ( BITLEN <= BITS_ON_COMP_MACH - 1) then ASSERTFAIL('GETSIGNED001');
T := GETFIELD (WORD, STARTBIT, BITLEN);
if (T>=TWOEXP[BITLEN-1]) and (BITLEN<WORDBITS) then
if BITLEN <= MAX_EXP_ON_COMP_MACH then
GETSIGNEDFIELD := T - TWOEXP[BITLEN]
else
begin
T := T - TWOEXP[MAX_EXP_ON_COMP_MACH];
GETSIGNEDFIELD := T - TWOEXP[MAX_EXP_ON_COMP_MACH];
end
else
GETSIGNEDFIELD := T;
end (*GETSIGNEDFIELD*);
(*****************end of comment out***************\
procedure PUTFIELD (var WORD : S1WORD; STARTBIT : S1BITNUM;
BITLEN : BITFIELD_LENGTH; FIELDVAL : integer);
(*Copies the low order BITLEN bits from FIELDVAL into a field
in WORD starting at bit number STARTBIT. (Bits are numbered
from left to right starting at 0.) High-order bits in FIELDVAL
should be either all ones or all zeros. Note : this routine
changes when S1WORDs really exist! At present assumes that
BITLEN <= BITS_ON_COMP_MACH - 1.*)
(*%IFT D10*) (*4AUG79 PTZ...*)
extern;
(*%ELSE*)
% external; \
(*%ENDC*) (*...4AUG79 PTZ*)
%***********insert assembly versions*************)
var W1, W2 : integer;
P : integer;
FIRSTAFTER : integer;
begin
if not (BITLEN <= BITS_ON_COMP_MACH - 1) then ASSERTFAIL('PUTFIELD 001');
W1 := WORD.LHALF;
W2 := WORD.RHALF;
FIRSTAFTER := STARTBIT + BITLEN;
if not ((0<=W1) and (W1<TWOEXP[18]) and
(0<=W2) and (W2<TWOEXP[18])) then ASSERTFAIL('PUTFIELD 002');
(*Zero out sign-extend bits of FIELDVAL.*)
if FIELDVAL < 0 then
if BITLEN <= MAX_EXP_ON_COMP_MACH then
FIELDVAL := FIELDVAL + TWOEXP[BITLEN]
else
begin
FIELDVAL := FIELDVAL + TWOEXP[MAX_EXP_ON_COMP_MACH];
FIELDVAL := FIELDVAL + TWOEXP[MAX_EXP_ON_COMP_MACH];
end;
if not (0<=FIELDVAL) then ASSERTFAIL('PUTFIELD 003');
if BITLEN <= MAX_EXP_ON_COMP_MACH then
if not (FIELDVAL < TWOEXP[BITLEN]) then ASSERTFAIL('PUTFIELD 004');
if STARTBIT <= 17 then
if FIRSTAFTER > 18 then
begin (*crosses 'halfword' boundary*)
W1 := W1 - W1 mod TWOEXP[18-STARTBIT]
+ FIELDVAL div TWOEXP[FIRSTAFTER-18];
W2 := W2 mod TWOEXP[36-FIRSTAFTER]
+ FIELDVAL mod TWOEXP[FIRSTAFTER-18]
* TWOEXP[36-FIRSTAFTER];
end
else
(*entirely in left half*)
W1 := W1 - W1 mod TWOEXP[18-STARTBIT]
+ W1 mod TWOEXP[18-FIRSTAFTER]
+ FIELDVAL * TWOEXP[18-FIRSTAFTER]
else
(*entirely in right half*)
W2 := W2 - W2 mod TWOEXP[36-STARTBIT]
+ W2 mod TWOEXP[36-FIRSTAFTER]
+ FIELDVAL * TWOEXP[36-FIRSTAFTER];
WORD.LHALF := W1;
WORD.RHALF := W2;
end (*PUTFIELD*);
(*****************end of comment out***************\
(** S1WORD_PROCESSOR_CLASS: REAL_TO_S1WORD ZSYMBOL_TO_S1WORDS INTEGER_TO_S1WORD SETREP_TO_S1WORDS **)
(**)
(* Comment out the 370 version...
Note that this procedure will not work until PASCAL supports
the type xreal.
procedure XREAL_TO_S1WORDS(var W1, W2 : S1WORD; XRVAL : xreal);
"*Translate an extended real value into a pair of S1 words.
WARNING: This routine is totally 370 PASCAL dependent;
It will be much simpler in its S-1 version.*"
type TRIT = 0..2;
var NEG : boolean;
EXP : integer;
TOP27, BOT29 : integer;
ICR : record
DUMMY : integer "*alignment*";
case TAG:TRIT of
0: (I: array [1..2] of integer);
1: (C: packed array [1..8] of char);
2: (R: real)
end;
begin
W1 := ZEROS1WORD; W2 := ZEROS1WORD;
ICR.R := XRVAL;
if ICR.R <> 0.0 then
begin
if ICR.R >= 0.0 then NEG := false else
begin ICR.R := -ICR.R; NEG := true end;
EXP := (ord(ICR.C[1]) - 64) * 4;
ICR.C[1] := chr(0);
TOP27 := ICR.I[1]*8 + ord(ICR.C[5]) div 32;
ICR.C[5] := chr(ord(ICR.C[5]) mod 32);
BOT29 := ICR.I[2];
while TOP27 < TWOEXP[26] do "*binary normalize*"
begin
EXP := EXP - 1;
BOT29 := BOT29 * 2;
TOP27 := TOP27 * 2;
if BOT29 >= TWOEXP[29] then
begin
BOT29 := BOT29 - TWOEXP[29];
TOP27 := TOP27 + 1
end
end;
EXP := EXP + 128; "*to excess 128*"
if NEG then "*want twos complement*"
begin
BOT29 := - BOT29;
if BOT29<>0 then TOP27 := TOP27 + 1;
TOP27 := - TOP27;
if (BOT29<>0) or (TOP27<>0) then EXP := EXP + 1;
EXP := - EXP
end;
PUTFIELD(W1,0,9,EXP);
PUTFIELD(W1,9,27,TOP27);
PUTFIELD(W2,0,29,BOT29)
end "*ICR <> 0.0*"
end "*XREAL_TO_S1WORDS*";
...*)
(* The following procedure will not work until PASCAL supports
the type xreal.
procedure XREAL_TO_S1WORDS(var W1, W2 : S1WORD; XRVAL : xreal);
"*Translate an extended real value into a pair of S1 words.
S-1 VERSION and PDP-10 VERSION (same procedure) *"
var RS10 : record "*for getting (only) word on PDP-10*"
case BIT of
0: (R: real; I: integer);
1: (S: HOST_SET_TYP) "*setch*"
end;
RSH : record "*for getting high order word on S-1*"
case BIT of
0: (I: integer; R: real);
1: (S: HOST_SET_TYP; J: integer) "*setch*"
end;
RSL : record "*for getting low order word on S-1*"
case BIT of
0: (R: real);
1: (S: HOST_SET_TYP) "*setch*"
end;
N : HOST_SET_EL_TYP; "*setch*"
begin
RS10.R := 0.0;
RS10.I := -1;
if 36 in RS10.S then
begin "*PDP-10*"
RS10.R := XRVAL;
RS10.I := 0;
W1 := ZEROS1WORD;
for N := 0 to WORDBITS-1 do
if N in RS10.S then
PUTFIELD (W1, N, 1, 1);
W2 := ZEROS1WORD;
end "*PDP-10*"
else
begin "*S-1*"
RSH.I := 0;
RSH.R := XRVAL;
W1 := ZEROS1WORD;
for N := WORDBITS-1 downto 0 do
if N in RSH.S then
PUTFIELD (W1, WORDBITS-1-N, 1, 1);
RSL.R := XRVAL;
W2 := ZEROS1WORD;
for N := WORDBITS-1 downto 0 do
if N in RSL.S then
PUTFIELD (W2, WORDBITS-1-N, 1, 1);
end "*S-1*";
end "*XREAL_TO_S1WORDS*";
...*)
(*procedure S1WORD_TO_REAL(var W : S1WORD; RVAL : real);*) (*23dec78 ALS*)
(*Translates one S1WORD into a real value.*)
procedure REAL_TO_S1WORD(var W : S1WORD; RVAL : real); (*LCW*)
(*Translate a real value into one S1 word.
S-1 VERSION and PDP-10 VERSION (same procedure).
This procedure assumes that the representation of a single-word real
is the same on the host compiler and the S-1 (true for the PDP-10 and
the S-1 Mark I).
A note about variant records and sets on various machines:
wd 1 wd 2 wd 3 wd 4
S-1 4 word set = 143-108, 107-72, 71-36, 35-0
S-1 2 word set = 71-36, 35-0
PDP-10 4 word set = 0-35, 36-71, 72-107, 108-143 (does not exist yet)
PDP-10 2 word set = 0-35, 36-71
The idea is to store the real number being translated in the first
word of the set and then find the right bit numbers in the appropriate
set representation to get it back out. *)
var RS : record (*16AUG79 PTZ*)
case BIT of
0: (R1: real;
I2: integer; (*don't declare in a list because*)
I3: integer; (*the last item in the list might*)
I4: integer); (*get allocated first*)
(*%IFT D10*) (*setch*) (*29AUG79 PTZ*)
1: (S: set of 0..36)
(*%ELSE*)
% 1: (S: set of 0..SET_MAX)\
(*%ENDC*)
end;
N : 0..SET_MAX; (*setch*) (*29AUG79 PTZ*)
begin
RS.R1 := 0.0;
RS.I2 := -1;
RS.I3 := 0;
RS.I4 := 0;
if 36 in RS.S then
begin (*PDP-10*)
RS.R1 := RVAL;
RS.I2 := 0;
W := ZEROS1WORD;
for N := 0 to WORDBITS-1 do
if N in RS.S then
PUTFIELD (W, N, 1, 1);
end (*PDP-10*)
else
begin (*S-1*) (*16AUG79 PTZ...*)
RS.R1 := RVAL;
RS.I2 := 0;
W := ZEROS1WORD;
for N := SET_MAX downto SET_MAX - WORDBITS do
if N in RS.S then
PUTFIELD (W, SET_MAX-N, 1, 1);
end (*S-1*); (*...16AUG79 PTZ*)
end (*REAL_TO_S1WORD*);
procedure ZSYMBOL_TO_S1WORDS(var W1, W2 : S1WORD; LSNAM : ALFA);
(*Translate a symbol name into a pair of S1 words.*)
var I, STBIT : integer;
SNAM : ZSYMBOL;
begin
for I := 1 to 8 do (*als/peg 25jul79*)
SNAM[I] := LSNAM[I]; (*als/peg 25jul79*)
W1 := ZEROS1WORD;
W2 := ZEROS1WORD;
STBIT := 0;
for I := 1 to WORDCHARS do
begin
PUTFIELD(W1,STBIT,CHARBITS,ord(SNAM[I])-CHARDIF); (*CHARDIF*)
STBIT := STBIT + CHARBITS
end;
STBIT := 0;
for I := 1 to WORDCHARS do
begin
PUTFIELD(W2,STBIT,CHARBITS,ord(SNAM[WORDCHARS+I])-CHARDIF); (*CHARDIF*)
STBIT := STBIT + CHARBITS
end
end (*ZSYMBOL_TO_S1WORDS*);
procedure INTEGER_TO_S1WORD (var W : S1WORD; I : integer);
(*Put the integer I into the S1WORD, sign-extended.*)
begin
W := ZEROS1WORD;
PUTFIELD (W, WORDBITS-(BITS_ON_COMP_MACH-1), BITS_ON_COMP_MACH-1, I);
if I < 0 then
PUTFIELD (W, 0, WORDBITS-(BITS_ON_COMP_MACH-1), -1);
end (*INTEGER_TO_S1WORD*);
procedure SETREP_TO_S1WORDS (var S1SET : S1SETREP; SVAL : SETREP);
(*Translate a set value to the S1's set representation.
Note that SET_MAX = S1SETREP_SIZE*WORDBITS - 1.*)
(*Would it be faster to equivalence a set to integers?*)
var INDEX : S1SETREP_INDEX; (*setch...*)
N, TMP1, TMP2 : SET_EL_TYP;
begin
for INDEX := 0 to S1SETREP_MAX do
begin
S1SET[INDEX] := ZEROS1WORD;
TMP1 := (S1SETREP_MAX + 1 - INDEX)*WORDBITS - 1;
TMP2 := (S1SETREP_MAX - INDEX)*WORDBITS;
for N := TMP1 downto TMP2 do
if SET_IN(N, SVAL) then
PUTFIELD(S1SET[INDEX], TMP1 - N, 1, 1);
end; (*...setch*)
end (*SETREP_TO_S1WORDS*);
(** MISCELLANEOUS_CLASS: LABELHASH LABELNUMBER MIN MAX POWER2 FLDW CVCHR_S1WORD_4 CVOS_S1WORD_12 CVOS_12 CVOS_10 CSP_HASH OPC_HASH NAME_TO_CSP MNEM_TO_OPC **)
(**)
function LABELHASH (LNUM : LBL_INDEX) : RNG_0_LBLHTSIZEM1;
begin
LABELHASH := ABS(LNUM) mod LBLHTSIZE;
end (*LABELHASH*);
function LABELNUMBER (var NAME : NAMEREC) : LBL_INDEX;
(*Converts a label name into a label number.*)
var I : ALFALEN;
NUM : 0..MAXLBL;
begin
I := 2; (*Skip the initial 'L'.*)
NUM := 0;
while (I<ALFASIZE) and (NAME.NAM[I]<>' ') do
begin
NUM := NUM*10 + ord(NAME.NAM[I]) - ord('0');
I := I + 1;
end;
if NAME.NAM[I] = ' ' then LABELNUMBER := NUM
else LABELNUMBER := NUM*10 + ord(NAME.NAM[I]) - ord('0');
end (*LABELNUMBER*);
function MIN (X, Y : integer) : integer;
begin
if X < Y then MIN := X else MIN := Y;
end (*MIN*);
function MAX (X, Y : integer) : integer;
begin
if X > Y then MAX := X else MAX := Y;
end (*MAX*);
function POWER2 (X : integer) : integer;
(*Return the integer k such that 2**k = X if X is a power of 2.
Otherwise return some k < 0.*)
var COUNT : integer;
begin
if X <= 0 then POWER2 := -999
else if X = 1 then POWER2 := 0
else if ODD(X) then POWER2 := -999
else if X = 2 then POWER2 := 1
else if X = 4 then POWER2 := 2
else if X = 8 then POWER2 := 3
else if X = 16 then POWER2 := 4
else if X = 32 then POWER2 := 5
else
begin
COUNT := 0;
repeat
COUNT := COUNT + 1;
X := X div 2;
until ODD(X) or (X <= 32);
if X = 32 then POWER2 := COUNT + 5
else POWER2 := -999;
end;
end (*POWER2*);
function FLDW(*(NUM : integer) : integer*);
(*Returns the field width required to exactly contain (with no
spaces) the value NUM represented in decimal.*)
var FW : integer;
begin
FW := 0;
if NUM < 0 then
begin
FW := 1;
NUM := abs(NUM)
end;
repeat
NUM := NUM div 10;
FW := FW + 1
until NUM = 0;
FLDW := FW
end (*FLDW*);
procedure CVCHR_S1WORD_4(var ANS : CHAR4; W : S1WORD); (*23DEC78 ALS...*)
(*Converts an S1WORD into a string of 4 characters.*)
var I : 1..4;
begin
for I := 1 to 4 do
ANS[I] := chr(GETFIELD(W, 9*(I - 1), 9) + CHARDIF);(*CHARDIF*)
end(*CVCHR_S1WORD_4*); (*...23DEC78 ALS*)
procedure CVOS_S1WORD_12(var ANS : CHAR12; W : S1WORD);
(*Converts an S1WORD into an octal string of 12 characters.*)
var I : 1..12;
begin
for I := 1 to 12 do
ANS[I] := chr(ord('0') + GETFIELD(W,3*(I-1),3));
I := 1;
while (I < 12) and (ANS[I] = '0') do
begin
ANS[I] := ' ';
I := I + 1
end
end (*CVOS_S1WORD_12*);
procedure CVOS_12(var ANS : CHAR12; K : NONNEGINT);
(*Converts a non-negative integer into an octal string of 12 chars.*)
var I : 1..12;
begin
ANS := ' 0';
I := 12;
while K > 0 do
begin
ANS[I] := chr(ord('0') + (K mod 8));
K := K div 8;
I := I - 1
end
end (*CVOS_12*);
procedure CVOS_10(var ANS : CHAR10; K : NONNEGINT);
(*Converts a non-negative integer into an octal string of 10 chars.*)
var I : 1..10;
begin
ANS := ' 0';
I := 10;
while K > 0 do
begin
if not (I>0) then ASSERTFAIL('CVOS_10 001');
ANS[I] := chr(ord('0') + (K mod 8));
K := K div 8;
I := I - 1
end
end (*CVOS_10*);
(* als should fix this if it becomes a problem...*)
function CSP_HASH (var NAM : ALFA) : integer;
begin
CSP_HASH := (ord(NAM[1])*676 + ord(NAM[2])*26 + ord(NAM[3]))
mod CSPHTSIZE;
end (*CSP_HASH*); (*...als fix*)
function OPC_HASH (var MNEM : CHAR4) : integer;
begin
OPC_HASH := (((ord(MNEM[2])*4 + ord(MNEM[1]))*8 + ord(MNEM[3]))*8
+ord(MNEM[4])*8) mod OPCHTSIZE;
(* OPC_HASH := (ord(MNEM[1])*676 + ord(MNEM[2])*26 + ord(MNEM[3]))
mod OPCHTSIZE; als 16jul79 *)
end (*OPC_HASH*);
function NAME_TO_CSP (var NAME : NAMEREC) : P_STANDARDPROC;
(*Look up the name in a hash table.*)
var H : integer;
begin
H := CSP_HASH (NAME.NAM);
while (CSPHASHTAB[H].CSPNAM <> NAME) and
(CSPHASHTAB[H].CSPNAM.NAM <> ' ') do
H := (H + 1) mod CSPHTSIZE;
if CSPHASHTAB[H].CSPNAM = NAME then
NAME_TO_CSP := CSPHASHTAB[H].CSP
else ERROR (WINVAL_CSP);
end (*NAME_TO_CSP*);
function MNEM_TO_OPC (var MNEM : CHAR4) : U_OPCODE;
(*Look up the mnemonic in a hash table.*)
var H : integer;
begin
H := OPC_HASH (MNEM);
while (OPCHASHTAB[H].OPCNAM <> MNEM) and
(OPCHASHTAB[H].OPCNAM <> ' ') do
H := (H + 1) mod OPCHTSIZE;
if OPCHASHTAB[H].OPCNAM = MNEM then
MNEM_TO_OPC := OPCHASHTAB[H].OPC
else ERROR (WINVAL_OPC);
end (*MNEM_TO_OPC*);
(** INSTRUCTION_PROCESSOR_CLASS: S1OPNDS_EQUAL S1OPND_TEMPLOC AFTER_FAKEOPS AFTER_NONS1LOC_FAKEOPS INVERT_OPCODE **)
(**)
function S1OPNDS_EQUAL (INST1LOC : AN_INSTREC; INST1OPNDNUM : OPNDNUM;(*PTZ*)
INST2LOC : AN_INSTREC;
INST2OPNDNUM : OPNDNUM) : boolean; (*DATASTRCH*)
(*Return true iff the 2 operands (including extended words) are equal,
assuming that the instructions are real S1 instructions, and also
that we're NOT comparing jump or skip destinations.
This routine does not consider different ways of referring to the same
location as being equal - operands must be IDENTICAL to match.
This routine is not passed INSTOPNDs so as to not sacrifice the
checking of VJOP and INSTOPND2*)
var INST1OPND, INST2OPND : INSTOPND;
begin
if not (not ((INST1LOC↑.OPFMT = VJOP) and (INST1OPNDNUM = OPND2NUM))
and not ((INST2LOC↑.OPFMT = VJOP) and (INST2OPNDNUM = OPND2NUM))) then
ASSERTFAIL('S1OPNDS_E001');
if INST1OPNDNUM = OPND1NUM then
INST1OPND := INST1LOC↑.INSTOPND1
else
INST1OPND := INST1LOC↑.INSTOPND2;
if INST2OPNDNUM = OPND1NUM then
INST2OPND := INST2LOC↑.INSTOPND1
else
INST2OPND := INST2LOC↑.INSTOPND2;
if (INST1OPND.REG = INST2OPND.REG) and (INST1OPND.F = INST2OPND.F) then
begin
if (INST1OPND.XWD = nil) or (INST2OPND.XWD = nil) then
S1OPNDS_EQUAL := INST1OPND.XWD = INST2OPND.XWD
else
S1OPNDS_EQUAL := INST1OPND.XWD↑ = INST2OPND.XWD↑
(*for this to work, the entire OPERAND_XWD block must be filled in
in a consistent way, including tag field. Any space unused by
a given variant should be zeroed*)
end
else
S1OPNDS_EQUAL := false
end (*S1OPNDS_EQUAL*);
function S1OPND_TEMPLOC (OPND : INSTOPND) : integer; (*PTZ*) (*DATASTRCH*)
(*Return value >= 0 iff the OPND starting at SHORTSTARTBIT
of the instruction at INSTLOC is a temporary location.
Currently checks only for temp register or
RTA, RTB & returns the register number if the OPND is a
temporary location. Should be changed when temporaries
are allowed to spill onto the stack or elsewhere*)
begin
if (OPND.XWD = nil) and (OPND.REG = 0)
and (((S1RTA <= OPND.F) and (OPND.F <= succ(S1RTB)))
or ((MINTMPS1REG <= OPND.F) and (OPND.F <= MAXTMPS1REG))) then
S1OPND_TEMPLOC := OPND.F
else
S1OPND_TEMPLOC := -1
end (*S1OPND_TEMPLOC*);
function AFTER_FAKEOPS(INSTLOC : AN_INSTREC) : AN_INSTREC; (*DATASTRCH*)
(*Return pointer to first non-FAKEOP instruction
starting at INSTLOC or beyond.*)
var LOOKING : boolean;
begin
LOOKING := true;
while LOOKING do
if INSTLOC = nil then LOOKING := false
else
if INSTLOC↑.OPFMT = VFAKEOP
then INSTLOC := INSTLOC↑.NEXTPTR
else LOOKING := false;
AFTER_FAKEOPS := INSTLOC
end (*AFTER_FAKEOPS*);
function AFTER_NONS1LOC_FAKEOPS(INSTLOC : AN_INSTREC) : AN_INSTREC; (*7MAR79 PTZ*)
(*Return pointer to either the first real instruction or the first
S1LOC instruction at INSTLOC or beyond*) (*DATASTRCH*)
var LOOKING : boolean;
begin
LOOKING := true;
while LOOKING do
if INSTLOC = nil then LOOKING := false
else
if (INSTLOC↑.OPCODE = XS1LOC) or (INSTLOC↑.OPFMT <> VFAKEOP) then
LOOKING := false
else
INSTLOC := INSTLOC↑.NEXTPTR;
AFTER_NONS1LOC_FAKEOPS := INSTLOC
end (*AFTER_NONS1LOC_FAKEOPS*);
procedure INVERT_OPCODE (INSTLOC : AN_INSTREC); (*7MAR79 PTZ*) (*DATASTRCH*)
(*Change the instruction at INSTLOC to have the reverse opcode,
i.e. the one so that OP X,Y = REVERSE_OP Y,X*)
var S1OPC : S1OPCODE;
begin
S1OPC := REVERSE_OP[INSTLOC↑.OPCODE];
if not (S1OPC <> XILLEGAL) then
ASSERTFAIL('INVERT_OP001');
INSTLOC↑.OPCODE := S1OPC
end (*INVERT_OPCODE*);
(** INSTRUCTION_PROCESSOR_CLASS: DELETE_INSTR INSERT_OPND1 PEEP_LOC_IS_FREE SWAP_OPERANDS INSTR_WORDS PRINTMAINCODE **)
(**)
procedure DELETE_INSTR (DELPTR : AN_INSTREC); (*7MAR79 PTZ*) (*DATASTRCH*)
(* Deletes the MAINCODE instruction whose 1st CODEREC is pointed to by DELPTR.*)
begin
with DELPTR↑ do
begin
if NEXTPTR <> nil then (*29AUG79 PTZ*)
NEXTPTR↑.PREVPTR := PREVPTR
else
begin
if not (MAINCODE.LAST = DELPTR) then
ASSERTFAIL('DELETE_IN001');
MAINCODE.LAST := PREVPTR;
end;
if PREVPTR <> nil then (*29AUG79 PTZ*)
PREVPTR↑.NEXTPTR := NEXTPTR
else
begin
if not (MAINCODE.FIRST = DELPTR) then
ASSERTFAIL('DELETE_IN002');
MAINCODE.FIRST := NEXTPTR;
end;
MAINCODE.NWORDS := MAINCODE.NWORDS - IWDS
end;
end (*DELETE_INSTR*);
procedure INSERT_OPND1 (INSTPTR : AN_INSTREC; OPND1 : INSTOPND); (*PTZ*)
(*DATASTRCH*)
var TWDS : integer;
begin
TWDS := 0;
with INSTPTR↑ do
begin
if INSTOPND1.XWD <> nil then
TWDS := TWDS + 1;
if OPND1.XWD <> nil then
TWDS := TWDS - 1;
INSTOPND1 := OPND1;
IWDS := IWDS - TWDS;
end;
MAINCODE.NWORDS := MAINCODE.NWORDS - TWDS
end (*INSERT_OPND1*);
function PEEP_LOC_IS_FREE (INSTLOC : AN_INSTREC; (*DATASTRCH*)
TMPLOC : integer) : boolean; (*7MAR79 PTZ*)
(*returns true iff the value contained in the location
given by TMPLOC is dead at INSTLOC, i.e. will not be used again.
This currently only applies to temp registers, but could also
apply to register spill locations (when they are implemented)
or other places, if FREEREGs are emitted to track such locations*)
var FOUND, STILL_LOOKING : boolean;
begin
FOUND := false;
STILL_LOOKING := INSTLOC <> nil;
while STILL_LOOKING and not FOUND do
begin
if INSTLOC↑.OPFMT <> VFAKEOP then
(* it's okay to cross S1LOC fakeinstrs here, because
they really belong to the next instr*)
STILL_LOOKING := false
else
begin (* VFAKEOP *)
if INSTLOC↑.OPCODE = XFREEREG then
begin
if INSTLOC↑.FAKEOPND = TMPLOC then
FOUND := true
end;
INSTLOC := INSTLOC↑.NEXTPTR;
STILL_LOOKING := INSTLOC <> nil
end (* VFAKEOP *)
end (*while*);
PEEP_LOC_IS_FREE := FOUND
end (*PEEP_LOC_IS_FREE*);
procedure SWAP_OPERANDS (INSTLOC : AN_INSTREC); (*7MAR79 PTZ*) (*DATASTRCH*)
(*Swaps the 2 operands of the instruction at INSTLOC*)
var TMPOPND1 : INSTOPND;
begin
with INSTLOC↑ do
begin
if not (OPFMT <> VJOP) then
ASSERTFAIL('SWAP_OPER001');
TMPOPND1 := INSTOPND1;
INSTOPND1 := INSTOPND2;
INSTOPND2 := TMPOPND1
end
end (*SWAP_OPERANDS*);
function INSTR_WORDS(INSTLOC : AN_INSTREC; INSTPC : integer) : integer;(*PTZ*)
(* Returns the number of WORDS that the instruction beginning at
INSTLOC occupies. During code concretization, INSTPC should be
a good estimate of the PC at the start of the instruction (it is
used to compute the size of jumps). At other times INSTPC can just
be a dummy value. Should not be trusted before ALL_CODE_EMITTED is true
(although it will still give the best known estimate) because the
amount of space a given instr is computed to occupy can increase up to that
time due to increases in the number of instrs in the codestream.
Alters MAINCODE.NWORDS and INSTLOC↑.IWDS if appropriate*) (*28APR79 PTZ*)
(*DATASTRCH*)
var TWDS, JMPOFF : integer;
TPC : 0..MAXS1LOC;
JDESTPTR : AN_INSTREC;
begin
with INSTLOC↑ do
begin
if (OPFMT = VJOP) and (not JUMPS_CONCRETIZED) then
begin
TWDS := 1;
if INSTOPND1.XWD <> nil then
TWDS := TWDS + 1;
if INSTOPND2.XWD <> nil then
TWDS := TWDS + 1;
JDESTPTR := DESTPTR;
if PR = 1 then
(*force two-word jump: this is in a jump table.
The instruction should be a JMPA so OPND1 won't
be extended. 2-word jump ASSERTed in CONCPAS3*)
TWDS := 2
else if JDESTPTR <> nil then
begin
if JDESTPTR↑.OPCODE <> XS1LOC then
begin
if ((MAINCODE.NWORDS > MAXJPROFFSET) or not ALL_CODE_EMITTED)
and (INSTOPND2.XWD = nil) then
TWDS := TWDS + 1 (*not already extended OPND2, may not
fit PC-relative. Assume worst case*)
end
else
begin
if (MAINCODE.NWORDS > MAXJPROFFSET)
and (INSTOPND2.XWD = nil) then
begin (*not already extended OPND2,
may not fit PC-relative*)
TPC := JDESTPTR↑.FAKEOPND;
if TPC <> S1LOCUNDEF then
begin
JMPOFF := (TPC - INSTPC) div WORDUNITS;
if (JMPOFF < MINJPROFFSET)
or (MAXJPROFFSET < JMPOFF) then
TWDS := TWDS + 1
end
else
TWDS := TWDS + 1 (*not enough info yet,
assume worst case*)
end
end
end;
MAINCODE.NWORDS := MAINCODE.NWORDS - IWDS + TWDS;
IWDS := TWDS;
end (* VJOP and jumps not concretized *);
INSTR_WORDS := IWDS
end (*with INSTLOC↑ do*)
end (*INSTR_WORDS*);
procedure PRINTMAINCODE; (*28APR79 PTZ*) (*DATASTRCH*)
(* prints out the contents of the codestream*)
var DEBUGPC, TDEBUGPC : 0..MAXS1LOC;
IPTR : AN_INSTREC;
begin
IPTR := MAINCODE.FIRST;
DEBUGPC := SEG_EP_RELPC;
while IPTR <> nil do
begin
TDEBUGPC := DEBUGPC; (*DISASSEMBLE changes its first param*)
(* if (DEBUGPC > 9500) and (DEBUGPC < 10500) then "for large files"*)
DISASSEMBLE(TDEBUGPC,IPTR);
DEBUGPC := DEBUGPC + IPTR↑.IWDS*WORDUNITS;
IPTR := IPTR↑.NEXTPTR;
end;
end (*PRINTMAINCODE*);
(** FIXUP_CLASS: FIXSOP FIXJOP FIXOPND2 ADD_XWPTR_TO_OPNDXWFIXLIST**)
(**)
procedure FIXSOP(SKIPLOC, SKIPDEST : AN_INSTREC); (*DATASTRCH*)
(*Set the destination pointer of the skip instruction to
point where SKIPDEST points.*)
begin
if not (SKIPLOC↑.OPFMT = VSOP) then
ASSERTFAIL('FIXSOP 001');
SKIPLOC↑.DESTPTR := SKIPDEST;
end (*FIXSOP*);
procedure FIXJOP(JUMPLOC, JUMPDEST : AN_INSTREC); (*DATASTRCH*)
(*Set the destination pointer of the jump instruction to
point where JUMPDEST points.*)
begin
if not (JUMPLOC↑.OPFMT = VJOP) then
ASSERTFAIL('FIXJOP 001');
JUMPLOC↑.DESTPTR := JUMPDEST;
end (*FIXJOP*);
procedure FIXOPND2 (INSTLOC : AN_INSTREC; FIXVAL : integer); (*DATASTRCH*)
(*Fixes the extended OPND2 field of the instruction by adding
FIXVAL to the appropriate part of it.The operand may be an
extended constant, a fixed-base address, or a variable-base
address.*)
var W : S1WORD;
CARRY : BIT;
T : integer;
UNKNOWN_LOC : integer;
begin
if (INSTLOC↑.INSTOPND2.XWD =nil) then
ASSERTFAIL('FIXOPND2 001');
if (INSTLOC↑.INSTOPND2.REG = 1) and (INSTLOC↑.INSTOPND2.F > 0) then
begin (*extended constant*)
(*Note : this section will be easier with real S1WORDs.*)
INTEGER_TO_S1WORD (W, FIXVAL);
with INSTLOC↑.INSTOPND2.XWD↑ do
begin
CARRY := 0;
T := VAL.RHALF + W.RHALF;
if T < TWOEXP[18] then VAL.RHALF := T
else
begin CARRY := 1;
VAL.RHALF := T - TWOEXP[18];
end;
T := VAL.LHALF + W.LHALF + CARRY;
VAL.LHALF := T mod TWOEXP[18];
end;
end (*extended constant*)
else
with INSTLOC↑.INSTOPND2.XWD↑ do
if V = 0 then
begin (*fixed-base address*)
T := FIXVAL + ADDR;
if (T<MINSIGNEDS1ADDR) or (T>MAXSIGNEDS1ADDR) then
ERROR (WADDR_OUT_OF_RANGE);
ADDR := T;
end (*fixed-base address*)
else
begin (*variable-base address*)
T := FIXVAL + DISP;
if (T<MINS1DISP) or (T>MAXS1DISP) then
ERROR (WDISP_OUT_OF_RANGE);
(*probable cause: data area too large*)
DISP := T;
end (*variable-base address*);
if TR_S1CODE then
begin
WRITELN (OUTPUT,
' Fixup performed to produce the instruction:');
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, INSTLOC);
end;
end (*FIXOPND2*);
procedure ADD_XWPTR_TO_OPNDXWFIXLIST(var CL : OPNDXWORDFIXLIST;
XPTR : AN_OPERANDXWORD); (*DATASTRCH*)
(*Appends a new OPNDXWORDREC to the front of operandfixlist CL, containing
pointer XPTR.*)
var X : AN_OPNDXWORDREC;
begin
NEWOPNDXWORDREC(X);
X↑.XWORDPTR := XPTR;
X↑.NEXTPTR := CL.FIRST;
if CL.FIRST = nil then CL.LAST := X;
CL.FIRST := X;
CL.NWORDS := 1 + CL.NWORDS
end (*ADD_XWPTR_TO_OPNDXWFIXLIST*);
(** FIXUP_CLASS: ADD_INSTPTR_TO_OPND2FIXLIST AP_JUMPLIST_PLUS_ONE AP_JUMP_TO_JUMPLIST JMP_TO_TABLE_RECORD_OR_FIX JUMP_TO_LABEL_RECORD_OR_FIX OPND2_RECORD_OR_FIX **)
(**)
procedure UPD_LBLTBL (var LPTR : A_LBLHASHENT; LNUM : LBL_INDEX;
LCLASS : LINTVAL_OR_LINSTPTR);
forward;
procedure ADD_INSTPTR_TO_OPND2FIXLIST(var CL : OPND2FIXLIST;
XINSTPTR : AN_INSTREC); (*DATASTRCH*)
(*Appends a new OPND2REC to the front of opnd2fixlist CL, containing
pointer XINSTPTR. Obtains a new OPND2REC, but does not use
NEWINSTREC.*)
var X : AN_OPND2REC;
begin
NEWOPND2REC(X);
X↑.OPND2IPTR := XINSTPTR;
X↑.NEXTPTR := CL.FIRST;
if CL.FIRST = nil then CL.LAST := X;
CL.FIRST := X;
CL.NWORDS := 1 + CL.NWORDS
end (*ADD_INSTPTR_TO_OPND2FIXLIST*);
procedure AP_JUMPLIST_PLUS_ONE(var JL1, JL2 : JUMPLIST;
JUMPLOC : AN_INSTREC); (*DATASTRCH*)
(*Appends JL2 onto JL1, and also appends the single jump at JUMPLOC
in FRONT of JL1.*)
begin
FIXJOP(JUMPLOC,JL1.FIRST);
if JL1.FIRST = nil then JL1.LAST := JUMPLOC;
JL1.FIRST := JUMPLOC;
FIXJOP(JL1.LAST,JL2.FIRST);
if JL2.FIRST <> nil then JL1.LAST := JL2.LAST;
JL1.NWORDS := 1 + JL1.NWORDS + JL2.NWORDS
end (*AP_JUMPLIST_PLUS_ONE*);
procedure AP_JUMP_TO_JUMPLIST(var JL : JUMPLIST;
JUMPLOC : AN_INSTREC); (*DATASTRCH*)
(*Appends the single jump at JUMPLOC onto the front of JL.*)
begin
if not (OPFORMAT[JUMPLOC↑.OPCODE] = VJOP) then (*PEG*)(*KYW 9/5*)
ASSERTFAIL('AP_JUMP_T001'); (*PEG*)
FIXJOP(JUMPLOC,JL.FIRST);
if JL.FIRST = nil then JL.LAST := JUMPLOC;
JL.FIRST := JUMPLOC;
JL.NWORDS := 1 + JL.NWORDS
end (*AP_JUMP_TO_JUMPLIST*);
procedure JMP_TO_TABLE_RECORD_OR_FIX(JUMPLOC : AN_INSTREC;
LNUM : LBL_INDEX); (*DATASTRCH*)
(*Records the jump in the fixup list for this label number or else
fixes it immediately. Also flags label table entry as a
jumptable label and flags the jumps in the table if the table
already exists.*)
var LPTR : A_LBLHASHENT; PTR : AN_INSTREC;
begin
UPD_LBLTBL(LPTR,LNUM,LINSTPTR);
with LPTR↑ do
begin
if not DEFINED then
AP_JUMP_TO_JUMPLIST(JLIST,JUMPLOC)
else
begin (*DEFINED*)
FIXJOP(JUMPLOC,INSTPTR);
if not JUMPTABLELABEL then
begin
PTR := INSTPTR;
while (PTR↑.OPCODE = XJMPA) and (PTR↑.INSTOPND2.XWD = nil) do
begin
PTR↑.PR := 1;
PTR := PTR↑.NEXTPTR;
end
end (*not JUMPTABLELABEL*)
end (*DEFINED*);
JUMPTABLELABEL := true
end (*with LPTR↑ do*)
end (*JMP_TO_TABLE_RECORD_OR_FIX*);
procedure JMP_TO_LABEL_RECORD_OR_FIX(JUMPLOC : AN_INSTREC;
LNUM : LBL_INDEX); (*DATASTRCH*)
(*Records the jump in the fixup list or fixes it immediately.*)
var LPTR : A_LBLHASHENT;
begin
UPD_LBLTBL(LPTR,LNUM,LINSTPTR);
with LPTR↑ do
if DEFINED then
FIXJOP(JUMPLOC,INSTPTR)
else
AP_JUMP_TO_JUMPLIST(JLIST,JUMPLOC)
end (*JMP_TO_LABEL_RECORD_OR_FIX*);
procedure OPND2_RECORD_OR_FIX(INSTLOC : AN_INSTREC;
LNUM : LBL_INDEX);
(*Records the instruction in the LINTVAL fixup list or fixes it
up immediately.*)
var LPTR : A_LBLHASHENT;
begin
UPD_LBLTBL(LPTR,LNUM,LINTVAL);
with LPTR↑ do
if DEFINED then
FIXOPND2(INSTLOC,INTVAL)
else
ADD_INSTPTR_TO_OPND2FIXLIST(CLIST,INSTLOC) (*DATASTRCH*)
end (*OPND2_RECORD_OR_FIX*);
(** OPERAND_PROCESSOR_CLASS: ISREG IS_T_REG IS_T_RG_NOT_RT ISSHORTCONST ISCONST EQUAL_OPERANDS REG_OPERAND IMM_OPERAND REAL_IMM_OPERAND IS_RT IS_RTA IS_RTB USES_RTA USES_RTB **)
(**)
function FITS_SHRT_OFFSET (DISP : S1DISP) : boolean;
forward;
function ISREG (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a register operand.*)
begin
ISREG := (OPND.X=0) and (OPND.REG=0);
end (*ISREG*);
function IS_T_REG (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a register operand
which is a temporary register (including RTA, RTB),
as opposed to a parm or display register.*)
begin
IS_T_REG := (OPND.X=0) and (OPND.REG=0)
and (((S1RTA<=OPND.F) and (OPND.F<=succ(S1RTB)))
or ((MINTMPS1REG<=OPND.F) and (OPND.F<=MAXTMPS1REG)));
end (*IS_T_REG*);
function IS_T_RG_NOT_RT (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a register operand
which is a temporary register (excluding RTB and RTA),
as opposed to a parm or display register.*)
begin
IS_T_RG_NOT_RT := (OPND.X=0) and (OPND.REG=0)
and (MINTMPS1REG<=OPND.F) and (OPND.F<=MAXTMPS1REG);
end (*IS_T_RG_NOT_RT*);
function ISSHORTCONST (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a short-constant operand.*)
begin
ISSHORTCONST := (OPND.X=0) and (OPND.REG=1);
end (*ISSHORTCONST*);
function ISCONST (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies a constant operand.*)
(*Note - this procedure is never used, but could be.*)
begin
ISCONST := ( (OPND.X=0) and (OPND.REG=1) )
or ( (OPND.X=1) and (OPND.REG=1) and (OPND.F<>0) );
end (*ISCONST*);
function EQUAL_OPERANDS (var X, Y : OPERAND) : boolean;
(*Return true iff two operands are equal in all fields.*)
var EQSOFAR : boolean;
begin
EQSOFAR :=
(X.X = Y.X)
and (X.REG = Y.REG)
and (X.F = Y.F)
and (X.FIXUP = Y.FIXUP)
and (X.FIXPTR = Y.FIXPTR)
and (X.XW.FMT = Y.XW.FMT);
if EQSOFAR then
case X.XW.FMT of
XW_EV :
EQSOFAR :=
(X.XW.P = Y.XW.P)
and (X.XW.V = Y.XW.V)
and (X.XW.D = Y.XW.D)
and (X.XW.I = Y.XW.I)
and (X.XW.S = Y.XW.S)
and (X.XW.ADDR = Y.XW.ADDR)
and (X.XW.REG = Y.XW.REG)
and (X.XW.DISP = Y.XW.DISP);
XW_C :
EQSOFAR :=
(X.XW.VAL = Y.XW.VAL)
end (*case*);
EQUAL_OPERANDS := EQSOFAR
end (*EQUAL_OPERANDS*);
procedure REG_OPERAND (var OPND : OPERAND; R : S1REGISTER);
(*Build an operand specifying register R.*)
begin
OPND := EMPTY_OP;
OPND.X := 0;
OPND.REG := 0;
OPND.F := ord(R);
end (*REG_OPERAND*);
procedure IMM_OPERAND (var OPND : OPERAND; VAL : integer);
(*Build an operand which specifies a constant integer value VAL.*)
begin
if (MINSHORTCONSTANT <= VAL) and (VAL <= MAXSHORTCONSTANT) then
begin
OPND := ZERO_OP;
if not (OPND.REG=1) then ASSERTFAIL('IMM_OPERA001');
OPND.F := VAL
end
else
begin
OPND := EXTENDED_ZERO_OP;
INTEGER_TO_S1WORD (OPND.XW.VAL, VAL);
end;
end (*IMM_OPERAND*);
procedure REAL_IMM_OPERAND (var OPND : OPERAND; RVAL : real); (*LCW*)
(*Build an operand which specifies a constant real value VAL.*)
begin
if RVAL = 0.0 then
OPND := ZERO_OP
else
begin
OPND := EXTENDED_ZERO_OP;
REAL_TO_S1WORD (OPND.XW.VAL, RVAL);
end;
end (*REAL_IMM_OPERAND*);
function IS_RT (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies RTA or RTB.*)
(*Note - this procedure is never used.*)
begin
IS_RT := (OPND.X=0) and (OPND.REG=0)
and ( (OPND.F=ord(S1RTA)) or (OPND.F=ord(S1RTB)) );
end (*IS_RT*);
function IS_RTA (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies RTA.*)
begin
IS_RTA := (OPND.X=0) and (OPND.REG=0)
and (OPND.F=ord(S1RTA));
end (*IS_RTA*);
function IS_RTB (var OPND : OPERAND) : boolean;
(*Return true iff OPND specifies RTB.*)
begin
IS_RTB := (OPND.X=0) and (OPND.REG=0)
and (OPND.F=ord(S1RTB));
end (*IS_RTB*);
function USES_RTA(var OPND : OPERAND) : boolean;
(*Return true iff the operand uses RTA.*)
begin
if (OPND.REG = S1RTA) or
(OPND.REG = 0) and (OPND.F = ord(S1RTA)) then
USES_RTA := true
else if (OPND.X <> 1) or
(OPND.REG = 1) and (OPND.F <> 0) then USES_RTA := false
else USES_RTA := (OPND.XW.V=1) and (OPND.XW.REG=S1RTA);
end (*USES_RTA*);
function USES_RTB(var OPND : OPERAND) : boolean;
(*Return true iff the operand uses RTB.*)
begin
if (OPND.REG = S1RTB) or
(OPND.REG = 0) and (OPND.F = ord(S1RTB)) then
USES_RTB := true
else if (OPND.X <> 1) or
(OPND.REG = 1) and (OPND.F <> 0) then USES_RTB := false
else USES_RTB := (OPND.XW.V=1) and (OPND.XW.REG=S1RTB);
end (*USES_RTB*);
(** OPERAND_PROCESSOR_CLASS: XTNDED_IMM_OPERAND REGDISP_OPERAND XTNDED_REGDISP_OPERAND EXT_REGADDR_OPERAND ADDR_OPERAND TWIDDLE_OPERAND **)
(**)
procedure XTNDED_IMM_OPERAND (var OPND : OPERAND; VAL : integer);
(*Build an extended operand which specifies
the integer constant VAL.*)
begin
OPND := EXTENDED_ZERO_OP;
INTEGER_TO_S1WORD (OPND.XW.VAL, VAL);
end (*XTNDED_IMM_OPERAND*);
procedure REGDISP_OPERAND (var OPND : OPERAND;
REG : S1REGISTER; DISP : S1DISP);
(*Build an operand specifying the address DISP(%REG). *)
begin
if FITS_SHRT_OFFSET(DISP) then
begin
OPND := EMPTY_OP;
OPND.X := 0;
OPND.REG := ord(REG);
OPND.F := DISP div WORDUNITS;
end
else
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 1;
OPND.F := 0; (*short zero*)
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 1;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.REG := ord(REG);
OPND.XW.DISP := DISP;
end;
end (*REGDISP_OPERAND*);
procedure XTNDED_REGDISP_OPERAND
(var OPND : OPERAND; REG : S1REGISTER; DISP : S1DISP);
(*Build an extended operand specifying the address DISP(%REG). *)
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 1;
OPND.F := 0; (*short zero*)
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 1;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.REG := ord(REG);
OPND.XW.DISP := DISP;
end (*XTNDED_REGDISP_OPERAND*);
procedure EXT_REGADDR_OPERAND (*EJG*)
(var OPND : OPERAND; REG : S1REGISTER; ADDR : S1ADDRESS);
(*Build an extended operand specifying the address ADDR(%REG). *)
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 0;
OPND.F := ord(REG);
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 0;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.ADDR := ADDR;
end (*EXT_REGADDR_OPERAND*);
procedure ADDR_OPERAND (var OPND : OPERAND; ADDR : S1ADDRESS);
(*Build an operand which specifies the absolute address ADDR.*)
begin
OPND := EMPTY_OP;
OPND.X := 1;
OPND.REG := 1;
OPND.F := 0; (*short zero*)
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 0;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.ADDR := ADDR;
end (*ADDR_OPERAND*);
procedure TWIDDLE_OPERAND (var OPND : OPERAND; TWIDDLE : integer);
(*Change OPND to specify a location TWIDDLE quarterwords
from where it does now, if that is possible.*)(*peg 16MAY79*)
begin
if TWIDDLE <> 0 then
if ISREG(OPND) then
if not (TWIDDLE mod WORDUNITS = 0) then ASSERTFAIL('TWIDDLE_O001')
else if not ((ord(FIRSTS1REG) <= OPND.F + (TWIDDLE div WORDUNITS))
and (OPND.F + (TWIDDLE div WORDUNITS) <= ord(LASTS1REG)))
then ASSERTFAIL('TWIDDLE_O002')
else OPND.F := OPND.F + (TWIDDLE div WORDUNITS)
else if (OPND.X = 0) (*Short-indexed*)
and ((ord(S1RPC) <= OPND.REG) and (OPND.REG <= ord(LASTS1REG))) then
if FITS_SHRT_OFFSET(OPND.F*WORDUNITS + TWIDDLE) then
OPND.F := OPND.F + (TWIDDLE div WORDUNITS)
else
begin (*Convert to extended*)
OPND.X := 1;
OPND.XW.FMT := XW_EV;
OPND.XW.P := 0;
OPND.XW.V := 1;
OPND.XW.D := 0;
OPND.XW.I := 0;
OPND.XW.S := 0;
OPND.XW.REG := OPND.REG;
OPND.XW.DISP := OPND.F*WORDUNITS + TWIDDLE;
OPND.REG := 1;
OPND.F := 0;
end (*Convert to extended*)
else if (OPND.X = 1) and (OPND.XW.I <> 1) then (*Extended addressing*)
begin
if OPND.XW.V = 0 then (*Fixed-based*)
OPND.XW.ADDR := OPND.XW.ADDR + TWIDDLE
else if OPND.XW.V = 1 then (*Variable-based*)
OPND.XW.DISP := OPND.XW.DISP + TWIDDLE
end (*Extended addressing*)
else if not (false) then ASSERTFAIL('TWIDDLE_O003'); (*All others*)
end (*TWIDDLE_OPERAND*);
(** REGISTER/GLOBAL_MANAGEMENT_CLASS: ALLOCGBL FREEGBL_S ALLAREFREE ALLOCRG ALLOCRP FREERG_S FINDRGBLOCK FINDRP FINDRG MOVE_AND_FREE_RTB CURRENT_PARMREG_COUNT IS_PARMREG CHECK_DSP_TMP_COLLISION RESERVE_PARMREGS **)
(**)
procedure EMITFAKEOP(S1OPC : S1OPCODE; OPND : integer); (*PBK*)
forward;
procedure EMITXOP (S1OPC : S1OPCODE; var OPND1, OPND2 : OPERAND);
forward;
procedure ALLOCGBL (G : S1GBL);
(*Allocates a global (ie. low-core memory word) G.*)
begin
if not (GISFREE[G]) then ASSERTFAIL('ALLOCGBL 001');
GISFREE[G] := false;
end (*ALLOCGBL*);
procedure FREEGBL_S (G : S1GBL);
(*Frees a global or global pair starting with word G.
The name FREEGBL_S is intended to suggest FREEGBL(S). *)
begin
if not ( not GISFREE[G]) then ASSERTFAIL('FREEGBL_S001');
GISFREE[G] := true;
end (*FREEGBL_S*);
function ALLAREFREE(FIRSTRG, SIZE : S1REGISTER) : boolean; (*PEG 14MAY79...*)
(*Checks to see if all registers in the block starting at FIRSTRG of
length SIZE are free.*)
var FREE : boolean;
I : S1REGISTER;
begin
FREE := RISFREE[FIRSTRG];
I := FIRSTRG + 1;
while FREE and (I <= FIRSTRG + SIZE - 1) do
begin
FREE := (*FREE and*) RISFREE[I];
I := I + 1;
end;
ALLAREFREE := FREE;
end (*ALLAREFREE*); (*...PEG 14MAY79*)
procedure ALLOCRG (R : S1REGISTER);
begin
if not (RISFREE[R]) then ASSERTFAIL('ALLOCRG 001');
RISFREE[R] := false;
RPWORD[R] := RSINGLE; (*PBK*)
end (*ALLOCRG*);
procedure ALLOCRP (R : S1REGISTER);
begin
if not ( RISFREE[R] and RISFREE[succ(R)] ) then ASSERTFAIL('ALLOCRP 001');
RISFREE[R] := false;
RISFREE[succ(R)] := false;
RPWORD[R] := R1STOFPAIR; (*PBK*)
RPWORD[succ(R)] := R2NDOFPAIR; (*PBK*)
end (*ALLOCRP*);
procedure FREERG_S(R : S1REGISTER);
(*Frees a register or register pair starting with R.
The name FREERG_S is intended to suggest FREERG(S). *)
begin
if (RISFREE[R]) or (RPWORD[R] = R2NDOFPAIR)
or (RPWORD[R] = RINBLOCK) then (*PEG*)
ASSERTFAIL('FREERG_S 001'); (*PBK*)
RISFREE[R] := true;
EMITFAKEOP(XFREEREG,R); (*PBK*)
if RPWORD[R] = R1STOFPAIR then (*PBK*)
begin
RISFREE[R+1] := true;
EMITFAKEOP(XFREEREG,R+1) (*PBK*)
end (* if RPWORD[R] = R1STOFPAIR then *) (*PBK*)
else if RPWORD[R] = R1STOFBLOCK then (*PEG 14MAY79...*)
begin
R := R + 1;
while RPWORD[R] = RINBLOCK do
begin
RISFREE[R] := true;
EMITFAKEOP(XFREEREG,R);
R := R + 1;
end;
end (*if RPWORD[R] = R1STOFBLOCK*); (*...PEG 14MAY79*)
end (*FREERG_S*);
procedure FINDRGBLOCK(SIZE : S1REGISTER); (*PEG 14MAY79...*)
(*Find and allocate a block of temporary registers (Not RTA or RTB) of
length SIZE. Return the smallest reg number in global variable NXTRG.*)
(* NOTE: THIS IS A TEMPORARY VERSION OF THIS ROUTINE. EVENTUALLY IT
WILL BE MUCH SMARTER, or replaced by calls to the runtime-stack temp
routines which are yet to be written. PEG. *)
var I : S1REGISTER;
begin
NXTRG := MINTMPS1REG;
while (NXTRG < MINDSPS1REG - SIZE)
and not ALLAREFREE(NXTRG, SIZE) do
NXTRG := NXTRG + 1;
if ALLAREFREE(NXTRG, SIZE) then
begin
RISFREE[NXTRG] := false;
RPWORD[NXTRG] := R1STOFBLOCK;
for I := (NXTRG + 1) to (NXTRG + SIZE - 1) do
begin
RISFREE[I] := false;
RPWORD[I] := RINBLOCK;
end;
if (NXTRG + SIZE - 1) > MAXTMPS1REG then
begin
MAXTMPS1REG := NXTRG + SIZE - 1;
MAXTMPPROC := CURPROC;
MAXTMPPLOC := CURPLOC
end
end
else ERROR(WEXPR_TOO_COMPLEX)
end (*FINDRGBLOCK*); (*...PEG 14MAY79*)
procedure FINDRP;
(*Find and allocate a pair of temporary registers (Not RTA or RTB).
Return the smaller reg number in global variable NXTRG.*)
begin
NXTRG := MINTMPS1REG;
while (NXTRG < MINDSPS1REG-2)
and not (RISFREE[NXTRG] and RISFREE[NXTRG+1]) do
NXTRG := NXTRG + 1;
if RISFREE[NXTRG] and RISFREE[NXTRG+1] then
begin
RISFREE[NXTRG] := false;
RISFREE[NXTRG+1] := false;
RPWORD[NXTRG] := R1STOFPAIR; (*PBK*)
RPWORD[NXTRG+1] := R2NDOFPAIR; (*PBK*)
if NXTRG+1 > MAXTMPS1REG then
begin
MAXTMPS1REG := NXTRG+1;
MAXTMPPROC := CURPROC;
MAXTMPPLOC := CURPLOC
end
end
else ERROR(WEXPR_TOO_COMPLEX)
end (*FINDRP*);
procedure FINDRG;
(*Find and allocate one of the temporary registers (Not RTA or
RTB), trying not to split potential pairs. Return reg number in
global variable NXTRG.*)
var I, ISAVE : S1REGISTER;
begin
NXTRG := MINTMPS1REG;
while (NXTRG < MINDSPS1REG-1) and not RISFREE[NXTRG] do
NXTRG := NXTRG + 1;
if not RISFREE[NXTRG] then
ERROR(WEXPR_TOO_COMPLEX)
else (*Found a free one (NXTRG). Can we improve on it?*)
begin
I := NXTRG;
while I <= MAXTMPS1REG do
begin
ISAVE := I;
repeat I := I + 1 until (I>MAXTMPS1REG) or not RISFREE[I];
if I-ISAVE = 1 then (*I-ISAVE = num of adjacent free regs*)
begin (*found an isolated free reg: use it*)
NXTRG := ISAVE;
I := MAXTMPS1REG + 1
end
else (*skip over next group of adjacent nonfree regs*)
while (I<=MAXTMPS1REG) and not RISFREE[I] do I := I + 1
end (*while I<=MAXTMPS1REG do*);
RISFREE[NXTRG] := false;
RPWORD[NXTRG] := RSINGLE; (*PBK*)
if NXTRG > MAXTMPS1REG then
begin
MAXTMPS1REG := NXTRG;
MAXTMPPROC := CURPROC;
MAXTMPPLOC := CURPLOC
end
end (*Found a free one*)
end (*FINDRG*);
procedure MOVE_AND_FREE_RTB;
(*We free RTB to use it to return function values or to
pass parameters to standard procs.
WARNING!!! This should not be called if an operand has
been built since it could invalidate the operand.*)
var MOVEOP : S1OPCODE;
OPNDR : OPERAND;
begin
if not (not RISFREE[S1RTB]) then ASSERTFAIL('MOVE_AND_001');
if RTBDOUB then
begin FINDRP; MOVEOP := XMOV_D_D end
else
begin FINDRG; MOVEOP := XMOV_S_S end;
REG_OPERAND(OPNDR,NXTRG);
EMITXOP(MOVEOP,OPNDR,OPNDRTB);
if not (RTBUSER <= TOP) then ASSERTFAIL('MOVE_AND_002');
with STK[RTBUSER] do
begin (*Update RTB datum to point to new reg*)
if FPA.WHICH = RGS then if FPA.RGADR = S1RTB then
FPA.RGADR := NXTRG;
if VPA1.VPA.WHICH = RGS then if VPA1.VPA.RGADR = S1RTB then
VPA1.VPA.RGADR := NXTRG;
if VPA2.VPA.WHICH = RGS then if VPA2.VPA.RGADR = S1RTB then
VPA2.VPA.RGADR := NXTRG
end;
FREERG_S(S1RTB)
end (*MOVE_AND_FREE_RTB*);
function CURRENT_PARMREG_COUNT : NUMBER_OF_PAREGS;
(*Returns the current number of parameter registers.*)
begin
CURRENT_PARMREG_COUNT := MINTMPS1REG - MINPARS1REG
end (*CURRENT_PARMREG_COUNT*);
function IS_PARMREG (R : S1REGISTER) : boolean;
(*Returns true iff R is a parameter register.*)
begin
IS_PARMREG := (MINPARS1REG<=R) and (R<MINTMPS1REG);
end (*IS_PARMREG*);
procedure CHECK_DSP_TMP_COLLISION;
(*Checks to see if there is a collision between the display
registers and the temporary registers. If so, an error message
is given; this is a non-recoverable situation requiring the user
to either simplify expressions or un-nest procedures.*)
begin
if MINDSPS1REG <= MAXTMPS1REG then
ERROR(WNESTING_TOO_DEEP_OR_EXPRESSION_TOO_COMPLEX)
end (*CHECK_DSP_TMP_COLLISION*);
procedure RESERVE_PARMREGS(COUNT : NUMBER_OF_PAREGS);
(*Changes the reservation to a given number of the parameter
registers, after asserting that any newly reserved ones are
available.*)
var I : S1REGISTER;
begin
for I := MINTMPS1REG to MINPARS1REG+COUNT-1 do
if not (RISFREE[I]) then ASSERTFAIL('RESERVE_P001');
MINTMPS1REG := MINPARS1REG + COUNT;
MAXTMPS1REG := MAX(MAXTMPS1REG,MINTMPS1REG-1);
CHECK_DSP_TMP_COLLISION
end (*RESERVE_PARMREGS*);
(** REGISTER/GLOBAL_MANAGEMENT_CLASS: FREEDATUMREGS FREEREGSBUTONE FREERGSBUTSOME FREEVPAREG FREVPARGUNLESS FREE_TEMP_REGS **)
(**)
procedure FREEDATUMREGS (STE : STKINX);
(*Free all the temp expr regs (not display or parm regs)
used in the datum. Does *not* change the datum.*)
begin
if (STK[STE].FPA.WHICH=RGS) then
if (MINTMPS1REG<=STK[STE].FPA.RGADR) and
(STK[STE].FPA.RGADR<=MAXTMPS1REG) or
(STK[STE].FPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].FPA.RGADR);
if STK[STE].NVPAS >= 1 then
if (STK[STE].VPA1.VPA.WHICH=RGS) then
if (MINTMPS1REG<=STK[STE].VPA1.VPA.RGADR) and
(STK[STE].VPA1.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA1.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S(STK[STE].VPA1.VPA.RGADR);
if STK[STE].NVPAS = 2 then
if (STK[STE].VPA2.VPA.WHICH=RGS) then
if (MINTMPS1REG<=STK[STE].VPA2.VPA.RGADR) and
(STK[STE].VPA2.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA2.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].VPA2.VPA.RGADR);
end (*FREEDATUMREGS*);
procedure FREEREGSBUTTHESE (STE : STKINX; REGS : SETOFS1REGS);
(*Free all the temp expr regs used in the datum,
*except* do not free registers in REGS if used.*)(*PEG*)
begin
with STK[STE] do
begin
if (FPA.WHICH=RGS) then
if not (FPA.RGADR in REGS) then
if (MINTMPS1REG<=FPA.RGADR) and
(FPA.RGADR<=MAXTMPS1REG) or
(FPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (FPA.RGADR);
if NVPAS >= 1 then
if (VPA1.VPA.WHICH=RGS) then
if not (VPA1.VPA.RGADR in REGS) then
if (MINTMPS1REG<=VPA1.VPA.RGADR) and
(VPA1.VPA.RGADR<=MAXTMPS1REG) or
(VPA1.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S(VPA1.VPA.RGADR);
if NVPAS = 2 then
if (VPA2.VPA.WHICH=RGS) then
if not (VPA2.VPA.RGADR in REGS) then
if (MINTMPS1REG<=VPA2.VPA.RGADR) and
(VPA2.VPA.RGADR<=MAXTMPS1REG) or
(VPA2.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (VPA2.VPA.RGADR);
end (*with STK[STE]*)
end (*FREEREGSBUTTHESE*);
(*NOTE - This procedure is never used. If it is used in the future, it
should be carefully checked for discrepencies (in other words,
it is not guaranteed to have been maintained)....
procedure FREERGSBUTSOME (STE, STE2 : STKINX);
%*Free all temp expr regs used in STK[STE], *except*
do not free any used in STK[STE2]. *\
var DONTFREE : set of S1REGISTER;
begin
DONTFREE := [ ];
if STK[STE].FPA.WHICH=MEM then
DONTFREE := DONTFREE + [STK[STE].FPA.RGADR];
if STK[STE].VPA1.VPA.WHICH=MEM then
DONTFREE := DONTFREE + [STK[STE].VPA1.VPA.RGADR];
if STK[STE].VPA2.VPA.WHICH=MEM then
DONTFREE := DONTFREE + [STK[STE].VPA2.VPA.RGADR];
if (STK[STE].FPA.WHICH=RGS) then
if not (STK[STE].FPA.RGADR in DONTFREE) then
if (MINTMPS1REG<=STK[STE].FPA.RGADR) and
(STK[STE].FPA.RGADR<=MAXTMPS1REG) or
(STK[STE].FPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].FPA.RGADR);
if STK[STE].NVPAS >= 1 then
if (STK[STE].VPA1.VPA.WHICH=RGS) then
if not (STK[STE].VPA1.VPA.RGADR in DONTFREE) then
if (MINTMPS1REG<=STK[STE].VPA1.VPA.RGADR) and
(STK[STE].VPA1.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA1.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S(STK[STE].VPA1.VPA.RGADR);
if STK[STE].NVPAS = 2 then
if (STK[STE].VPA2.VPA.WHICH=RGS) then
if not (STK[STE].VPA2.VPA.RGADR in DONTFREE) then
if (MINTMPS1REG<=STK[STE].VPA2.VPA.RGADR) and
(STK[STE].VPA2.VPA.RGADR<=MAXTMPS1REG) or
(STK[STE].VPA2.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (STK[STE].VPA2.VPA.RGADR);
end %*FREERGSBUTSOME*\;
...end of unused procedure.*)
procedure FREEVPAREG (var V : VPAREC);
(*Free the temp expr reg used in V, if any. Does not change V.*)
begin
if V.VPA.WHICH = RGS then
if (MINTMPS1REG <= V.VPA.RGADR) and
(V.VPA.RGADR <= MAXTMPS1REG) or
(V.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (V.VPA.RGADR);
end (*FREEVPAREG*);
procedure FREVPARGUNLESS (var V : VPAREC; R : S1REGISTER);
(*Free the temp expr reg used in V, if any, *EXCEPT* does
not free R if used. Does not change V.*)
begin
if V.VPA.WHICH = RGS then
if V.VPA.RGADR <> R then
if (MINTMPS1REG <= V.VPA.RGADR) and
(V.VPA.RGADR <= MAXTMPS1REG) or
(V.VPA.RGADR in [S1RTA, S1RTB]) then
FREERG_S (V.VPA.RGADR);
end (*FREVPARGUNLESS*);
procedure FREE_TEMP_REGS;
(*Release all the temp expr regs, including RTA and RTB.*)
var R : S1REGISTER;
begin
if not RISFREE[S1RTA] then FREERG_S (S1RTA);
if not RISFREE[S1RTB] then FREERG_S (S1RTB);
for R := MINTMPS1REG to MAXTMPS1REG do
if not RISFREE[R] then FREERG_S (R);
end (*FREETEMPREGS*);
(** FORM_CODE CLASS: FORM_CW_OPERAND FORMFAKEINST FORMSOP FORMJOP FORMTOP FORMXOP
(**) (*DATASTRCH*)
procedure FORM_CW_OPERAND(BUFINX : INSTBUFINX; (*DATASTRCH*)
var OPND : INSTOPND;
SHORTSTARTBIT : S1BITNUM);
(*Build an bit coded S1 operand from OPND in S1INSTBUF[S1INST]
and S1INSTBUF[BUFINX].
Position the first bit of the short part at bit SHORTSTARTBIT in
S1INSTBUF[S1INST]; leave other 24 bits alone. *)
var X : BIT;
begin
if OPND.XWD <> nil then X := 1
else X := 0;
PUTFIELD(S1INSTBUF[S1INST],SHORTSTARTBIT+OPNDX_START,OPNDX_LEN,X);
PUTFIELD(S1INSTBUF[S1INST],
SHORTSTARTBIT+OPNDREG_START,OPNDREG_LEN,OPND.REG);
PUTFIELD(S1INSTBUF[S1INST],SHORTSTARTBIT+OPNDF_START,OPNDF_LEN,OPND.F);
if X = 1 then
begin (*extended word*)
if OPND.XWD↑.FMT = XW_C then
begin
if not ((OPND.F > 0) and (OPND.REG = 1)) then
ASSERTFAIL('OPND_CW__001');
S1INSTBUF[BUFINX] := OPND.XWD↑.VAL
end
else (*extended address*)
begin
if not (not ((OPND.F > 0) and (OPND.REG = 1))) then
ASSERTFAIL('FORM_CW__002');
PUTFIELD(S1INSTBUF[BUFINX],XWP_START,XWP_LEN,OPND.XWD↑.P);
PUTFIELD(S1INSTBUF[BUFINX],XWV_START,XWV_LEN,OPND.XWD↑.V);
PUTFIELD(S1INSTBUF[BUFINX],XWD_START,XWD_LEN,OPND.XWD↑.D);
PUTFIELD(S1INSTBUF[BUFINX],XWI_START,XWI_LEN,OPND.XWD↑.I);
PUTFIELD(S1INSTBUF[BUFINX],XWS_START,XWS_LEN,OPND.XWD↑.S);
if OPND.XWD↑.V = 0 then
PUTFIELD(S1INSTBUF[BUFINX],
XWADDR_START,XWADDR_LEN,OPND.XWD↑.ADDR)
else
begin
PUTFIELD(S1INSTBUF[BUFINX],
XWREG_START,XWREG_LEN,OPND.XWD↑.REG);
PUTFIELD(S1INSTBUF[BUFINX],
XWDISP_START,XWDISP_LEN,OPND.XWD↑.DISP)
end
end (*extended address*);
end (*extended word*)
end (*FORM_CW_OPND*);
procedure FORMFAKEINST( IPTR : AN_INSTREC ); (*DATASTRCH*)
(*generate a bit coded fake S1 instruction in CODEBUF*)
begin
PUTFIELD(S1INSTBUF[S1INST],OPCODE_START,OPCODE_LEN,
HARDOPCODE[IPTR↑.OPCODE]);
PUTFIELD(S1INSTBUF[S1INST],FAKEOPND_START,FAKEOPND_LEN,
IPTR↑.FAKEOPND);
end (*FORMFAKEINST*);
procedure FORMSOP(IPTR : AN_INSTREC); (*DTATSTRCH*)
(*generate a bit coded SOP S1 instruction in CODEBUF*)
begin
PUTFIELD(S1INSTBUF[S1INST],OPCODE_START,OPCODE_LEN,
HARDOPCODE[IPTR↑.OPCODE]);
PUTFIELD(S1INSTBUF[S1INST],SKP_START,SKP_LEN,IPTR↑.SKP);
FORM_CW_OPERAND(S1OPND2XWD,IPTR↑.INSTOPND2, OPND2_START);
FORM_CW_OPERAND(S1OPND1XWD,IPTR↑.INSTOPND1, OPND1_START);
end (*FORMSOP*);
procedure FORMJOP(IPTR : AN_INSTREC); (*DATASTRCH*)
(*generate a bit coded JOP S1 instruction in CODEBUF*)
begin
PUTFIELD(S1INSTBUF[S1INST],OPCODE_START,OPCODE_LEN,
HARDOPCODE[IPTR↑.OPCODE]);
PUTFIELD(S1INSTBUF[S1INST],PR_START,PR_LEN,IPTR↑.PR);
if ((JUMPS_CONCRETIZED and (IPTR↑.PR = 0))
or (not JUMPS_CONCRETIZED)) then
FORM_CW_OPERAND(S1OPND2XWD,IPTR↑.INSTOPND2,OPND2_START)
else (*PR = 1*)
PUTFIELD (S1INSTBUF[S1INST],J_START,J_LEN,IPTR↑.J);
FORM_CW_OPERAND(S1OPND1XWD,IPTR↑.INSTOPND1,OPND1_START);
end (*FORMJOP*);
procedure FORMTOP(IPTR : AN_INSTREC); (*DATASTRCH*)
(*generate a bit coded TOP S1 instruction in CODEBUF*)
begin
PUTFIELD(S1INSTBUF[S1INST],OPCODE_START,OPCODE_LEN,
HARDOPCODE[IPTR↑.OPCODE]);
PUTFIELD(S1INSTBUF[S1INST],T_START,T_LEN,IPTR↑.T);
FORM_CW_OPERAND(S1OPND2XWD,IPTR↑.INSTOPND2, OPND2_START);
FORM_CW_OPERAND(S1OPND1XWD,IPTR↑.INSTOPND1, OPND1_START);
end (*FORMTOP*);
procedure FORMXOP(IPTR : AN_INSTREC); (*DATASTRCH*)
(*generate a bit coded XOP S1 instruction in CODEBUF*)
begin
PUTFIELD(S1INSTBUF[S1INST],OPCODE_START,OPCODE_LEN,
HARDOPCODE[IPTR↑.OPCODE]);
FORM_CW_OPERAND(S1OPND2XWD,IPTR↑.INSTOPND2, OPND2_START);
FORM_CW_OPERAND(S1OPND1XWD,IPTR↑.INSTOPND1, OPND1_START);
end (*FORMXOP*);
(** CODE_EMITTER_CLASS: CONNECT_TO_FIXUP_LIST EMIT_INSTR_OPNDS INSERT_INSTR_OPNDS **)
(**)
(* procedure BUILD_CW_OPERAND is substituted by CONNECT_TO_FIXUP_LIST *)
procedure CONNECT_TO_FIXUP_LIST(var OPND :OPERAND; XPTR : AN_OPERANDXWORD);
(*Add a pointer to OPERANDXWORD of OPND to a fixup list*)
(*DATASTRCH*)
begin
if not (OPND.X = 1) then ASSERTFAIL('CONN_FIX 001');
case OPND.FIXUP of
STRINGFIX : ADD_XWPTR_TO_OPNDXWFIXLIST(STRINGFIXLIST,XPTR);
SETFIX : ADD_XWPTR_TO_OPNDXWFIXLIST( SETFIXLIST,XPTR);
REALFIX : ADD_XWPTR_TO_OPNDXWFIXLIST( REALFIXLIST,XPTR);
BOUNDFIX : ADD_XWPTR_TO_OPNDXWFIXLIST(BOUNDFIXLIST,XPTR);
XTRNSYMFIX : ADD_XWPTR_TO_OPNDXWFIXLIST(OPND.FIXPTR↑.FIXLIST,XPTR);
end(*case*)
end(*CONNECT_TO_FIXUP_LIST*);
procedure EMIT_INSTR_OPNDS(var OPND1, OPND2 : OPERAND; IWORDS : IWDRNG);
(*DATASTRCH*)
(*Common to EMIT routines. Fill in all the operand fields (at
NEWINSTREC), emit the instr. record, and allocate and connect to
NEWINSTREC↑.INSTOPND1 and 2 extended words if necessary.
Update MAINCODE to reflect insertions.*)
var TXWORDPTR : AN_OPERANDXWORD;
begin
if MAINCODE.FIRST = nil then
begin
MAINCODE.FIRST := NEWINSTREC;
NEWINSTREC↑.PREVPTR := nil
end
else
begin
MAINCODE.LAST↑.NEXTPTR := NEWINSTREC;
NEWINSTREC↑.PREVPTR := MAINCODE.LAST
end;
MAINCODE.LAST := NEWINSTREC;
NEWINSTREC↑.NEXTPTR := nil;
if OPND2.X = 1 then
begin(*extended operand2 *)
new(TXWORDPTR);
TXWORDPTR↑ := OPND2.XW;
IWORDS := IWORDS + 1;
end
else TXWORDPTR := nil;
with NEWINSTREC↑.INSTOPND2 do
begin
REG := OPND2.REG;
F := OPND2.F;
XWD := TXWORDPTR;
end;
if OPND2.FIXUP <> NOFIX then
CONNECT_TO_FIXUP_LIST(OPND2, TXWORDPTR);
if OPND1.X = 1 then
begin (*extended operand1 *)
new(TXWORDPTR);
TXWORDPTR↑ := OPND1.XW;
IWORDS := IWORDS + 1
end
else TXWORDPTR := nil;
with NEWINSTREC↑.INSTOPND1 do
begin
REG := OPND1.REG;
F := OPND1.F;
XWD := TXWORDPTR
end;
if OPND1.FIXUP <> NOFIX then
CONNECT_TO_FIXUP_LIXT(OPND1,TXWORDPTR);
NEWINSTREC↑.IWDS := IWORDS;
MAINCODE.NWORDS := MAINCODE.NWORDS + IWORDS; (*28AUG79 PTZ*)
MAKE_NEWINSTREC(NEWINSTREC);
end(*EMIT_INSTR_OPNDS*);
procedure INSERT_INSTR_OPNDS(var WHERE, TPTR: AN_INSTREC;
var OPND1, OPND2 : OPERAND; IWORDS : IWDRNG);
(*DATASTRCH*)
(*Common to EMIT routines. Fill in all the short operand fields in
TPTR↑. insert TPTR↑ immediately following WHERE (at
front if WHERE = nil), and allocate and connect to TPTR↑.INSTOPND1 and 2
if needed. Return a pointer to the last INSTREC inserted in WHERE.
Update MAINCODE to reflect insertions. Does Not touch
NEWINSTREC.*)
var TXWORDPTR : AN_OPERANDXWORD;
begin
if WHERE = nil then
begin
TPTR↑.NEXTPTR := MAINCODE.FIRST;
TPTR↑.PREVPTR := nil;
if not (MAINCODE.FIRST = nil) then MAINCODE.FIRST↑.PREVPTR := TPTR;
MAINCODE.FIRST := TPTR;
end(*WHERE = nil*)
else
begin
if not (MAINCODE.FIRST <> nil) then ASSERTFAIL('INSERT_IN001');
TPTR↑.NEXTPTR := WHERE↑.NEXTPTR;
TPTR↑.PREVPTR := WHERE;
if WHERE↑.NEXTPTR <> nil then (*29AUG79 PTZ*)
WHERE↑.NEXTPTR↑.PREVPTR := TPTR;
WHERE↑.NEXTPTR := TPTR;
end(*WHERE <> nil*);
if MAINCODE.LAST = WHERE then MAINCODE.LAST := TPTR;
WHERE := TPTR;
if OPND2.X = 1 then
begin(*extended operand2*)
new(TXWORDPTR);
TXWORDPTR↑ := OPND2.XW;
IWORDS := IWORDS + 1;
end
else TXWORDPTR := nil;
with TPTR↑.INSTOPND2 do
begin
REG := OPND2.REG;
F:= OPND2.F;
XWD := TXWORDPTR
end;
if OPND2.FIXUP <> NOFIX then
CONNECT_TO_FIXUP_LIST(OPND2, TXWORDPTR);
if OPND1.X = 1 then
begin(*extended OPND1*)
new(TXWORDPTR);
TXWORDPTR↑ := OPND1.XW;
IWORDS := IWORDS + 1;
end
else TXWORDPTR := nil;
with TPTR↑.INSTOPND1 do
begin
REG := OPND1.REG;
F := OPND1.F;
XWD := TXWORDPTR;
end;
if OPND1.FIXUP <> NOFIX then
CONNECT_TO_FIXUP_LIST(OPND1,TXWORDPTR);
TPTR↑.IWDS := IWORDS;
MAINCODE.NWORDS := MAINCODE.NWORDS + IWORDS (*28AUG79 PTZ*)
end (*INSERT_INSTR_OPNDS*);
(** CODE_EMITTER_CLASS: EMITFAKEOP INSERTSOP INSERTJOP INSERTXOP EMIT_S1WORD EMIT_ZEROS1WORD **)
(**)
procedure EMITFAKEOP(* (S1OPC : S1OPCODE; OPND : integer) *); (*PBK*)
(*Emit the fake S1 instruction described.*) (*DATASTRCH*)
begin
if not (OPFORMAT[S1OPC] = VFAKEOP) then ASSERTFAIL('EMITFAKEI001');
with NEWINSTREC↑ do
begin
OPCODE := S1OPC;
OPFMT := VFAKEOP;
FAKEOPND := OPND;
IWDS := 0
end;
if MAINCODE.FIRST = nil then
begin
MAINCODE.FIRST := NEWINSTREC;
NEWINSTREC↑.PREVPTR := nil
end
else
begin
MAINCODE.LAST↑.NEXTPTR := NEWINSTREC;
NEWINSTREC↑.PREVPTR := MAINCODE.LAST
end;
MAINCODE.LAST := NEWINSTREC;
NEWINSTREC↑.NEXTPTR := nil;
MAKE_NEWINSTREC(NEWINSTREC);
end (*EMITFAKEOP*);
procedure INSERTSOP(WHERE : AN_INSTREC; S1OPC : S1OPCODE;
SKIPDIST : S1SKIPDISTANCE;
var OPND1, OPND2 : OPERAND;
SKIPDEST : AN_INSTREC); (*DATASTRCH*)
(*Insert the described SOP instruction after the instrec
that WHERE points to, updating MAINCODE to reflect changes.
Does not use NEWINSTREC. WHERE=nil means insert at front.*)
var IWORDS : IWDRNG;
TINSTRPTR : AN_INSTREC;
begin
if not ( OPFORMAT[S1OPC] = VSOP) then ASSERTFAIL('INSERTSOP001');
MAKE_NEWINSTREC(TINSTRPTR);
with TINSTRPTR↑ do
begin
OPCODE := S1OPC;
OPFMT := VSOP;
SKP := SKIPDIST;
DESTPTR := SKIPDEST;
DUMMYSPACE := 0; (*2SEP79 PTZ*)
end;
IWORDS := 1;
INSERT_INSTR_OPNDS(WHERE, TINSTRPTR, OPND1,OPND2, IWORDS);
end (*INSERTSOP*);
procedure INSERTJOP(WHERE : AN_INSTREC; S1OPC : S1OPCODE;
FORCELONG : BIT; var OPND1, OPND2 : OPERAND;
JUMPDEST : AN_INSTREC); (*DATASTRCH*)
(*Insert the described JOP instruction after the INSTREC that WHERE
points to, updating MAINCODE to reflect changes. Does Not use
NEWINSTREC. WHERE = nil means insert at front.*)
var IWORDS : IWDRNG;
TINSTPTR : AN_INSTREC;
DUMMYPC : integer; (*KYW 8/28/79*)
begin
if not (OPFORMAT[S1OPC] = VJOP) then ASSERTFAIL('INSERTJOP001');
MAKE_NEWINSTREC(TINSTPTR);
with TINSTPTR↑ do
begin
OPCODE := S1OPC;
OPFMT := VJOP;
PR := FORCELONG;
J := 0;
DESTPTR := JUMPDEST;
DUMMYSPACE := 0; (*2SEP79 PTZ*)
end;
IWORDS := 1;
INSERT_INSTR_OPNDS(WHERE, TINSTPTR, OPND1,OPND2,IWORDS);
DUMMYPC := 0; (*KYW 8/28/79*)
WHERE↑.IWDS := INSTR_WORDS(WHERE,DUMMYPC); (*KYW 8/28/79*)
(* WHERE↑.IWDS is changed also by side effect *) (*KYW 8/28/79*)
(* MAINCODE.NWORDS is updatd by INSTR_WORDS in this case.*)
end (*INSERTJOP*);
procedure INSERTXOP(WHERE : AN_INSTREC; S1OPC : S1OPCODE;
var OPND1, OPND2 : OPERAND); (*DATASTRCH*)
(*Insert the described XOP instruction after the coderec
that WHERE points to, updating MAINCODE to reflect changes.
Does not use NEWINSTREC. WHERE=nil means insert at front.*)
var IWORDS : IWDRNG;
TINSTPTR : AN_INSTREC;
begin
if not ( OPFORMAT[S1OPC] = VXOP) then ASSERTFAIL('INSERTXOP001');
MAKE_NEWINSTREC(TINSTPTR);
with TINSTPTR↑ do
begin
OPCODE := S1OPC;
OPFMT := VXOP;
end;
IWORDS := 1;
INSERT_INSTR_OPNDS(WHERE, TINSTPTR, OPND1, OPND2, IWORDS);
end (*INSERTXOP*);
procedure EMIT_S1WORD(var LIST : CODELIST; var W : S1WORD);
(*Add the word to the end of the codelist.*)
begin
if LIST.NWORDS = 0 then
begin
NEWCODEREC(LIST.FIRST);
LIST.LAST := LIST.FIRST;
LIST.NWORDS := 1
end
else
begin
NEWCODEREC(LIST.LAST↑.NEXTPTR);
LIST.LAST := LIST.LAST↑.NEXTPTR;
LIST.NWORDS := LIST.NWORDS + 1
end;
LIST.LAST↑.NEXTPTR := nil;
LIST.LAST↑.CODEWORD := W
end (*EMIT_S1WORD*);
procedure EMIT_ZEROS1WORD(var LIST : CODELIST;
var WHERE : A_CODEREC);
(*Add a zero S1WORD to the end of LIST, returning a pointer to it.*)
begin
if LIST.NWORDS = 0 then
begin
NEWCODEREC(LIST.FIRST);
LIST.LAST := LIST.FIRST;
LIST.NWORDS := 1
end
else
begin
NEWCODEREC(LIST.LAST↑.NEXTPTR);
LIST.LAST := LIST.LAST↑.NEXTPTR;
LIST.NWORDS := LIST.NWORDS + 1
end;
LIST.LAST↑.NEXTPTR := nil;
LIST.LAST↑.CODEWORD := ZEROS1WORD;
WHERE := LIST.LAST
end (*EMIT_ZEROS1WORD*);
(** CODE_EMITTER_CLASS: EMITSOP EMITJOP EMITTOP EMITXOP ALLOC_AND_EMIT_TOP **)
(**)
procedure EMITSOP(S1OPC : S1OPCODE; SKIPDIST : S1SKIPDISTANCE;
var OPND1, OPND2 : OPERAND; SKIPDEST : AN_INSTREC);
(*Add described SOP instr to the end of MAINCODE.*) (*DATASTRCH*)
var IWORDS : IWDRNG;
begin
if not (OPFORMAT[S1OPC] = VSOP) then ASSERTFAIL('EMITSOP 001');
with NEWINSTREC↑ do
begin
OPCODE := S1OPC;
OPFMT := VSOP;
SKP := SKIPDIST;
DESTPTR := SKIPDEST;
DUMMYSPACE := 0; (*2SEP79 PTZ*)
end;
IWORDS := 1;
EMIT_INSTR_OPNDS(OPND1,OPND2,IWORDS);
end (*EMITSOP*);
procedure EMITJOP(S1OPC : S1OPCODE; FORCELONG : BIT;
var OPND1, OPND2 : OPERAND; JUMPDEST : AN_INSTREC);
(*Add described JOP instr to the end of MAINCODE.
FORCELONG = 1 means that the
jump must be concretized into a two word instruction (or a one
word instr and a one word no-op). This bit of information is
stored for the time being in the PR field.*) (*DATASTRCH*)
var IWORDS : IWDRNG;
DUMMYPC : integer; (*used just to match the parameter,does not contain
useful information*) (*KYW 8/28/79*)
begin
if not (OPFORMAT[S1OPC] = VJOP) then ASSERTFAIL('EMITJOP 001');
with NEWINSTREC↑ do
begin
OPCODE := S1OPC;
OPFMT := VJOP;
PR := FORCELONG;
J := 0;
DESTPTR := JUMPDEST; (*2SEP79 PTZ*)
DUMMYSPACE := 0;
end;
IWORDS := 1;
EMIT_INSTR_OPNDS(OPND1, OPND2, IWORDS);
DUMMYPC := 0; (*KYW 8/28/79*)
MAINCODE.LAST↑.IWDS := INSTR_WORDS(MAINCODE.LAST,DUMMYPC); (*KYW 8/29/79*)
(* MAINCODE.LAST↑.IWDS is changed also by side effect*)
(* MAINCODE.NWORDS is updated by INSTR_WORDS in this case*)
end (*EMITJOP*);
procedure EMITTOP(S1OPC : S1OPCODE; TEMPT : TWOBITS;
var OPND1, OPND2 : OPERAND); (*DATASTRCH*)
(*Add described TOP instr to end of MAINCODE.*)
var IWORDS : IWDRNG;
begin
if not (OPFORMAT[S1OPC] = VTOP) then ASSERTFAIL('EMITTOP 001');
with NEWINSTREC↑ do
begin
OPCODE := S1OPC;
OPFMT := VTOP;
T := TEMPT;
end;
IWORDS := 1;
EMIT_INSTR_OPNDS(OPND1,OPND2,IWORDS);
end (*EMITTOP*);
procedure EMITXOP(*(S1OPC : S1OPCODE; var OPND1, OPND2 : OPERAND)*);
(*Add described XOP instr to end of MAINCODE.*) (*DATASTRCH*)
var IWORDS : IWDRNG;
begin
if not (OPFORMAT[S1OPC] = VXOP) then ASSERTFAIL('EMITXOP 001');
with NEWINSTREC↑ do
begin
OPCODE := S1OPC;
OPFMT := VXOP;
end;
IWORDS := 1;
EMIT_INSTR_OPNDS(OPND1,OPND2,IWORDS);
end (*EMITXOP*);
procedure ALLOC_AND_EMIT_TOP(var R : S1REGISTER; OPCD : S1OPCODE;
var OPND1, OPND2 : OPERAND;
DOUBRES, DOUB1, DOUB2 : boolean;
STE : STKINX);
(*Allocate a register (returned in R) for the result of a TOP,
perhaps emitting a MOV to free it, and emit the TOP. Assume that
OPND1 and OPND2 regs were Not freed in advance, but will be freed
after return, being careful to not free reg R even if it
coincides with OPND1 or OPND2.
Note: DOUBRES, DOUB1, DOUB2 are true iff the result, opnd1,
and opnd2 respectively are doublewords. This can be deduced
from the opcode if the proper tables are declared.*)
var OPNDR : OPERAND;
MOVEOP : S1OPCODE;
begin
if not ( REVERSE_OP[OPCD]<>XILLEGAL) then ASSERTFAIL('ALLOC_AND001');
if IS_T_RG_NOT_RT(OPND1) and (DOUBRES <= DOUB1) then
begin
if IS_T_RG_NOT_RT(OPND2) and
(DOUBRES <= DOUB2) and (OPND2.F < OPND1.F) then
begin
R := OPND2.F;
EMITTOP (REVERSE_OP[OPCD], 0, OPND2, OPND1);
if DOUB2 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
else
begin
R := OPND1.F;
EMITTOP (OPCD, 0, OPND1, OPND2);
if DOUB1 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
end
else if IS_T_RG_NOT_RT(OPND2) and (DOUBRES <= DOUB2) then
begin
R := OPND2.F;
EMITTOP (REVERSE_OP[OPCD], 0, OPND2, OPND1);
if DOUB2 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
else if IS_RTA(OPND1) then
begin
if DOUBRES then FINDRP else FINDRG;
R := NXTRG; REG_OPERAND (OPNDR, R);
EMITTOP (OPCD, 1, OPNDR, OPND2);
end
else if IS_RTA(OPND2) then
begin
if DOUBRES then FINDRP else FINDRG;
R := NXTRG; REG_OPERAND (OPNDR, R);
EMITTOP (REVERSE_OP[OPCD], 1, OPNDR, OPND1);
end
else if RISFREE[S1RTA] or USES_RTA(OPND1) or USES_RTA(OPND2) then
begin
if not RISFREE[S1RTA] then FREERG_S (S1RTA);
if DOUBRES then ALLOCRP(S1RTA) else ALLOCRG(S1RTA);
R := S1RTA;
EMITTOP (OPCD, 2, OPND1, OPND2);
end
else if RISFREE[S1RTB] or USES_RTB(OPND1) or USES_RTB(OPND2) then
begin
if not RISFREE[S1RTB] then FREERG_S (S1RTB);
if DOUBRES then ALLOCRP(S1RTB) else ALLOCRG(S1RTB);
RTBUSER := STE;
RTBDOUB := DOUBRES;
R := S1RTB;
EMITTOP (OPCD, 3, OPND1, OPND2);
end
else
begin (*if all else fails, emit a move*)
if DOUB1 or DOUBRES then FINDRP else FINDRG;
REG_OPERAND (OPNDR, NXTRG);
if DOUB1 then MOVEOP:=XMOV_D_D else MOVEOP:=XMOV_S_S;
EMITXOP (MOVEOP, OPNDR, OPND1);
R := NXTRG;
EMITTOP (OPCD, 0, OPNDR, OPND2);
if DOUB1 and not DOUBRES then
begin
FREERG_S (R);
ALLOCRG (R);
end;
end
end (*ALLOC_AND_EMIT_TOP*);
(** DATUM_PROCESSOR_CLASS: LENGTH_TO_INTOPNDTYPE REG_DATUM COERCE_DATUM CVT_INT_DATUM COERCE_INT_DATUM COERCE_TWO_DATUMS DAT_IS_REG DAT_ISFREE_REG DAT_IS_T_REG DAT_IS_FILADR LOADSTKENTRY LOADSTACKEXCEPT BJUMP_TO_BINTVAL INCREMENT_DATUM XCHANGE_STKENTS **)
(**)
procedure GET_OPERAND (var OPND : OPERAND; STE : STKINX);
forward;
procedure FIT_IN_OPERAND (var TOO_COMPLICATED : boolean;
var OPND : OPERAND; STE : STKINX);
forward;
procedure MOVE_QUANTITY (var DEST : OPERAND; STE : STKINX);
forward;
procedure SIMPLIFY (STE : STKINX);
forward;
procedure ADD_SUB_SINGLE (var DEST : S1REGISTER; ADDOP : S1OPCODE;
var OPND1, OPND2 : OPERAND; STE : STKINX);
forward;
function LENGTH_TO_INTOPNDTYPE(LEN : DTYPE_LENGTH) : OPNDTYPE;
(*Return the integer type whose precision corresponds to
the length LEN in bits -- als/peg 19jul79.*)
begin
if LEN mod QWBITS <> 0 then ASSERTFAIL('LENGTH_TO001');
if LEN = DWBITS then
LENGTH_TO_INTOPNDTYPE := TYPUI
else if LEN = WORDBITS then
LENGTH_TO_INTOPNDTYPE := TYPUJ
else if LEN = HWBITS then
LENGTH_TO_INTOPNDTYPE := TYPH
else if LEN = QWBITS then
LENGTH_TO_INTOPNDTYPE := TYPQ
else ASSERTFAIL('LENGTH_TO002');
end (*LENGTH_TO_INTOPNDTYPE*);
procedure REG_DATUM (STE : STKINX; RESCODESTART : AN_INSTREC;
RESTYPE : OPNDTYPE; RESREG : S1REGISTER); (*DATASTRCH*)
(*Build a datum in STK[STE] describing a quantity stored in a
given register, with a given CODESTART and DTYPE.*)
(* als/peg 03jul79 *)
var R : S1REGISTER;
begin
STK[STE] := ZERODATUM;
with STK[STE] do
begin
CODESTART := RESCODESTART;
DTYPE := RESTYPE;
if RPWORD[RESREG] = R1STOFPAIR then
DLENGTH := 2*WORDBITS
else if RPWORD[RESREG] = R1STOFBLOCK then
begin
R := RESREG + 1;
DLENGTH := WORDBITS;
while RPWORD[R] = RINBLOCK do
begin
DLENGTH := DLENGTH + WORDBITS;
R := R + 1;
end;
end
else DLENGTH := WORDBITS;
MTYPE := R_SPACE;
NVPAS := 1;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := RESREG;
end;
end (*REG_DATUM*);
procedure COERCE_DATUM(STE : STKINX; RTYPE : OPNDTYPE);
(*Perform a type coercion of the datum STE to type RTYPE*)
var OPND, OPNDR : OPERAND;
OPRRG : S1REGISTER;
MOVEOP : S1OPCODE;
begin
with STK[STE] do
if DTYPE <> RTYPE then
begin
MOVEOP := MOV_X_Y[RTYPE,DTYPE];
if MOVEOP = XILLEGAL then
ERROR(WINVALID_TYPE_COERCION);
if IS_CONSTANT(STE) then
if (DTYPE = TYPUN) and (RTYPE = TYPUA) then
(*leave TYPUN alone, it's already TYPUA (sort of)*)
else if IS_INTEGER[RTYPE] and IS_INTEGER[DTYPE] then
if (RTYPE in [TYPUI, TYPUK])
or (DTYPE in [TYPUI, TYPUK]) then
ERROR(WNOT_IMPLEMENTED)
else
DTYPE := RTYPE
else if IS_INTEGER[RTYPE] and IS_REAL[DTYPE] then
if RTYPE = TYPUQ then ERROR(WNOT_IMPLEMENTED)
else
begin
FPA.WHICH := MEM;
FPA.MEMADR.DSPLMT := round(RCNST);
DTYPE := RTYPE
end
else if IS_REAL[RTYPE] and IS_INTEGER[DTYPE] then
if (RTYPE = TYPUQ) or (DTYPE in [TYPUI, TYPUK]) then
ERROR(WNOT_IMPLEMENTED)
else
begin
RCNST := FPA.MEMADR.DSPLMT;
FPA := ZEROFPA;
DTYPE := RTYPE;
end
else ERROR(WINVALID_TYPE_COERCION)
else if DTYPE = TYPUM then
begin
if not (RTYPE = TYPUA) then ASSERTFAIL('COERCE_DA001');
repeat SIMPLIFY(STE) until DTYPE = TYPUA;
end
else
begin
GET_OPERAND(OPND,STE);
(*pn 27sep79...*) if RTYPE = TYPUS then
FINDRGBLOCK(S1SETREP_SIZE)
(*...pn 27sep79*) else if IS_DOUBLE[RTYPE] then FINDRP else FINDRG;
OPRRG := NXTRG;
REG_OPERAND(OPNDR, OPRRG);
EMITXOP(MOVEOP, OPNDR, OPND);
FREEDATUMREGS(STE);
REG_DATUM(STE, CODESTART, RTYPE, OPRRG);
end;
end;
end (*COERCE_DATUM*);
procedure CVT_INT_DATUM(STE : STKINX);
(*The datum in the stack at STE is TYPUJ or TYPUL. If it is of qword
or hword length, convert it to TYPQ or TYPH -- als/peg 20jul79.*)
begin
with STK[STE] do
begin
if not (DTYPE in [TYPUJ, TYPUL]) then ASSERTFAIL('CVT_INT_D001');
if DLENGTH <> WORDBITS then
DTYPE := LENGTH_TO_INTOPNDTYPE(DLENGTH);
end (*with*);
end (*CVT_INT_DATUM*);
procedure COERCE_INT_DATUM(STE : STKINX);
(*The datum in the stack at STE is TYPUJ or TYPUL, but may be
of qword or hword length. Coerce it to sword length --
als/peg 20jul79.*)
var RESTYPE : OPNDTYPE;
begin
with STK[STE] do
begin
if not (DTYPE in [TYPUJ, TYPUL]) then ASSERTFAIL('COERCE_IN001');
RESTYPE := DTYPE;
if DLENGTH <> WORDBITS then
begin
DTYPE := LENGTH_TO_INTOPNDTYPE(DLENGTH);
COERCE_DATUM(STE, RESTYPE);
end;
end (*with*);
end (*COERCE_INT_DATUM*);
procedure COERCE_TWO_DATUMS(var IS_OKTYPE :
OPNDTYPE_TO_BOOLEAN_ARRAY);
(*Instead of IS_OKTYPE, could possibly pass a set
of legal result types.*)
(*Take the top two datums on the stack, verify that they represent
acceptable types, and emit code to coerce them both to the same
result type.*)
var TYPE1, TYPE2, RTYPE : OPNDTYPE;
begin
TYPE1 := STK[TOP-1].DTYPE;
TYPE2 := STK[TOP].DTYPE;
if not IS_OKTYPE[TYPE1] or not IS_OKTYPE[TYPE2] then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
RTYPE := ARITH_RESULT_TYPE[TYPE1,TYPE2];
if RTYPE = ILLARITH then
ERROR (WBINARY_OPND_TYPE_CONFLICT);
COERCE_DATUM(TOP-1,RTYPE);
COERCE_DATUM(TOP,RTYPE)
end (*COERCE_TWO_DATUMS*);
function DAT_IS_REG (STE : STKINX) : boolean;
(*Return true iff datum specifies a quantity contained in a
register.*)
begin
with STK[STE] do
DAT_IS_REG := (FINALIND = IND0) and
(FPA = ZEROFPA) and
(DTYPE <> TYPUM) and
( (DTYPE <> TYPUB)
or (BREPRES = BINTVAL) ) and
(NVPAS = 1) and
(VPA1.VPAIND = IND1) and
(VPA1.VSHIFT = 0) and
(VPA1.VPA.WHICH = RGS);
end (*DAT_IS_REG*);
function DAT_ISFREE_REG (STE : STKINX) : boolean; (*EJG 17JAN79*)
(*PEG 18FEB79*)
(*Return true iff datum specifies a quantity contained in a
register which is currently free.*)
begin
DAT_ISFREE_REG := false;
with STK[STE] do
if (FINALIND = IND0) and
(FPA = ZEROFPA) and
(DTYPE <> TYPUM) and
( (DTYPE <> TYPUB)
or (BREPRES = BINTVAL) ) and
(NVPAS = 1) and
(VPA1.VPAIND = IND1) and
(VPA1.VSHIFT = 0) and
(VPA1.VPA.WHICH = RGS)
then if RISFREE[VPA1.VPA.RGADR] then DAT_ISFREE_REG := true;
end (*DAT_ISFREE_REG*);
function DAT_IS_T_REG (STE : STKINX) : boolean;
(*Return true iff datum specifies a quantity contained in a
temporary register.*)
begin
with STK[STE] do
DAT_IS_T_REG := (FINALIND = IND0) and
(FPA = ZEROFPA) and
(DTYPE <> TYPUM) and
( (DTYPE <> TYPUB)
or (BREPRES = BINTVAL) ) and
(NVPAS = 1) and
(VPA1.VPAIND = IND1) and
(VPA1.VSHIFT = 0) and
(VPA1.VPA.WHICH = RGS) and
(*finally:*)
((VPA1.VPA.RGADR = S1RTA) or
(VPA1.VPA.RGADR = S1RTB) or
(MINTMPS1REG <= VPA1.VPA.RGADR) and
(VPA1.VPA.RGADR <= MAXTMPS1REG));
end (*DAT_IS_T_REG*);
function DAT_IS_FILADR (STE : STKINX) : boolean;
(*Return true iff datum specifies the quantity at U-Code
location <1,LCIOFILADR>. *)
begin
with STK[STE] do
DAT_IS_FILADR :=
(DTYPE = TYPUA) and
(FINALIND = IND0) and
(FPA = ZEROFPA) and
(NVPAS = 1) and
(VPA1.VSHIFT = 0) and
(VPA1.VPAIND = IND1) and
(VPA1.VPA.WHICH = MEM) and
(VPA1.VPA.MEMADR.LVL = 1) and
(VPA1.VPA.MEMADR.DSPLMT
= LCIOFILADR + FILE_OFFSET);
end (*DAT_IS_FILADR*);
procedure XCHANGE_STKENTS (STE1, STE2 : STKINX); (*peg 15MAY79*)
(*Exchange the datum at STK[STE1] with that at STK[STE2].*)
var T_DATUM : DATUM;
begin
T_DATUM := STK[STE1];
STK[STE1] := STK[STE2];
STK[STE2] := T_DATUM;
end (*XCHANGE_STKENTS*);
procedure BJUMP_TO_BINTVAL (STE : STKINX);
(*Convert the datum, which is a boolean in bjump form, into
bintval form.*)
(*This procedure probably could be done more easily simply by
loading a zero, then executing a conditional-skip tree which
may load a one at the end or may skip the load. LCW*)
var LOADFIRST : boolean;
FALLTHRUJUMP : AN_INSTREC; (*DATASTRCH*)
OPNDR, OPND2 : OPERAND;
TLOAD, FLOAD, SKIPLOC, CONTINUE : AN_INSTREC; (*DATASTRCH*)
P, NEXT : AN_INSTREC; (*DATASTRCH*)
begin
with STK[STE] do
begin
if not ((DTYPE=TYPUB) and (BREPRES=BJUMP)) then
ASSERTFAIL('BJUMP_TO_001');
FALLTHRUJUMP := BFALLTHRUSKIPLOC↑.NEXTPTR; (*DATASTRCH*)
if BTRUELIST.NWORDS < BFALSELIST.NWORDS then
LOADFIRST := (true)
else LOADFIRST := (false);
P := BFALLTHRUSKIPLOC; (*DATASTRCH*)
DELETE_INSTR(FALLTHRUJUMP); (*DATASTRCH*)
(*remove the fall-through jump*)
if LOADFIRST <> BJUMPON then
begin
BFALLTHRUSKIPLOC↑.OPCODE := INVERSE_SKIP[BFALLTHRUSKIPLOC↑.OPCODE];(*DATASTRCH*)
BJUMPON := not BJUMPON;
end;
REG_OPERAND (OPNDR, VPA1.VPA.RGADR);
(*Use the reg allocated to the bjump when created.*)
if LOADFIRST = (true) then
begin (*load true first*)
IMM_OPERAND (OPND2, 1);
INSERTXOP (P, XMOV_Q_Q, OPNDR, OPND2);
TLOAD := P↑.NEXTPTR;
P := TLOAD;
INSERTSOP (P, XSKP_EQL_Q, 0, ZERO_OP, ZERO_OP, nil);
SKIPLOC := P↑.NEXTPTR;
INSERTXOP (SKIPLOC, XMOV_Q_Q, OPNDR, ZERO_OP); (*DATASTRCH*)
FLOAD := SKIPLOC↑.NEXTPTR; (*DATASTRCH*)
FIXSOP (BFALLTHRUSKIPLOC, FLOAD);
CONTINUE := FLOAD↑.NEXTPTR; (*DATASTRCH*)
if CONTINUE <> nil then FIXSOP (SKIPLOC, CONTINUE)
else FIXSOP (SKIPLOC, NEWINSTREC);
end (*load true first*)
else
begin (*load false first*)
INSERTXOP (P, XMOV_Q_Q, OPNDR, ZERO_OP);
FLOAD := P↑.NEXTPTR;
P := FLOAD;
INSERTSOP (P, XSKP_EQL_Q, 0, ZERO_OP, ZERO_OP, nil);
SKIPLOC := P↑.NEXTPTR;
IMM_OPERAND (OPND2, 1);
INSERTXOP (SKIPLOC, XMOV_Q_Q, OPNDR, OPND2); (*DATASTRCH*)
TLOAD := SKIPLOC↑.NEXTPTR; (*DATASTRCH*)
FIXSOP (BFALLTHRUSKIPLOC, TLOAD);
CONTINUE := TLOAD↑.NEXTPTR; (*DATASTRCH*)
if CONTINUE <> nil then FIXSOP (SKIPLOC, CONTINUE)
else FIXSOP (SKIPLOC, NEWINSTREC);
end (*load false first*);
P := BTRUELIST.FIRST;
while P <> nil do
begin
NEXT := P↑.DESTPTR; (*DATASTRCH*)
FIXJOP (P, TLOAD);
P := NEXT;
end;
P := BFALSELIST.FIRST;
while P <> nil do
begin
NEXT := P↑.DESTPTR; (*DATASTRCH*)
FIXJOP (P, FLOAD);
P := NEXT;
end;
REG_DATUM (STE, CODESTART, TYPUB, VPA1.VPA.RGADR);
BREPRES := BINTVAL;
end (*with STK[STE] do*)
end (*BJUMP_TO_BINTVAL*);
procedure LOADSTKENTRY(STE : STKINX);
(*Force an actual load of the item at STK[STE] -- als/peg 27jul79.*)
var OPND, OPNDR : OPERAND;
R : S1REGISTER;
begin
with STK[STE] do
if (NVPAS>0) and
not DAT_IS_FILADR(STE) and
not DAT_IS_T_REG(STE) and
not DAT_ISFREE_REG(STE) then
if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
BJUMP_TO_BINTVAL(STE)
else
begin
GET_OPERAND(OPND, STE);
if not DAT_IS_T_REG(STE) then
begin (*generate a MOV*)
(*peg 27sep79...*) if DTYPE = TYPUS then
FINDRGBLOCK(S1SETREP_SIZE)
(*...peg 27sep79*) else if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
R := NXTRG;
REG_OPERAND (OPNDR, R);
MOVE_QUANTITY (OPNDR, STE);
FREEDATUMREGS (STE);
REG_DATUM (STE, CODESTART, DTYPE, R);
end (*generate a MOV*);
end;
end (*LOADSTKENTRY*);
procedure LOADSTACKEXCEPT (BOTEXC, TOPEXC : STKINX);
(*In order to prevent possible side effects because of standard
procedure calls or user procedure calls inside codeforks, we
call this procedure to load most items on the virtual stack into
temporary registers. Exceptions are constants (which are
completely in virtual form) and bjump booleans (which have no
storage associated with them that can be changed). There are
often stack entries, however, which we don't need or wish to
load in this way, because they are parameters which are being
passed or because we are about to throw them away anyway. The
range BOTEXC<=STE<=TOPEXC consists of such entries, and items in
that part of the stack are not loaded. Any DATUM which is a
file address is also not loaded. (A kludge so CHECKFILADR
will be able to tell which DATUMs are file addresses.) Later,
file addresses will be passed as parameters.*)
var OPNDR : OPERAND;
STE : STKINX;
R : S1REGISTER;
begin
for STE := BOT to TOP do
with STK[STE] do
if ((STE<BOTEXC) or (STE>TOPEXC)) and (NVPAS>0) and
((DTYPE<>TYPUB) or (BREPRES=BINTVAL)) and
not DAT_IS_FILADR(STE) and
not DAT_IS_T_REG(STE) and
not DAT_ISFREE_REG(STE) then (*EJG 17JAN79*)
begin (*generate a MOV*)
(*pn 27sep79...*) if DTYPE = TYPUS then
FINDRGBLOCK(S1SETREP_SIZE)
(*...pn 27sep79*) else if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
R := NXTRG;
REG_OPERAND (OPNDR, R);
MOVE_QUANTITY (OPNDR, STE);
FREEDATUMREGS (STE);
REG_DATUM (STE, CODESTART, DTYPE, R);
end (*generate a MOV*);
end (*LOADSTACKEXCEPT*);
procedure INCREMENT_DATUM(STE : STKINX; INCR : integer); (*EJG*)
(*Increment the datum STE by the constant amount INCR*)
var
OLDTYPE : OPNDTYPE;
OPND1, OPND2 : OPERAND;
COMBINABLE, CALCULABLE, RESDBL : boolean;
TOOMUCH1 : boolean;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((IS_INTEGER[DTYPE])
or (DTYPE in [TYPUA, TYPUB, TYPUC, TYPUM])) then
ERROR (WNOT_DISCRETE_TYPE);
if INCR <> 0 then
begin
OLDTYPE := DTYPE;
if DTYPE in [TYPUB, TYPUC] then
begin
if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
BJUMP_TO_BINTVAL (STE);
DTYPE := TYPQ;
end;
if not (DTYPE in [TYPUA, TYPUI, TYPUJ, TYPUK, TYPUL, TYPUM]) then
COERCE_DATUM(STE, TYPUJ);
if DTYPE in [TYPUI, TYPUK] then
begin
GET_OPERAND (OPND1, STE);
IMM_OPERAND (OPND2, INCR);
ALLOC_AND_EMIT_TOP (DEST, XADD_D, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, STE);
FREEREGSBUTTHESE (STE, [DEST]);
REG_DATUM (STE, CODESTART, OLDTYPE, DEST);
end (*if IS_INTEGER*)
else
begin (*TYPUA, TYPUJ, TYPUL, TYPUM*)
COMBINABLE := false;
CALCULABLE := false;
repeat
if FINALIND = IND0 then COMBINABLE := true
else
begin
FIT_IN_OPERAND (TOOMUCH1, OPND1, STE);
if TOOMUCH1 then
SIMPLIFY (STE)
else
CALCULABLE := true;
end (*not combinable*);
until COMBINABLE or CALCULABLE;
if COMBINABLE then
FPA.MEMADR.DSPLMT := FPA.MEMADR.DSPLMT + INCR
else
begin (*calculable*)
IMM_OPERAND (OPND2, INCR);
ADD_SUB_SINGLE (DEST, XADD_S, OPND1, OPND2, STE);
FREEREGSBUTTHESE (STE, [DEST]);
REG_DATUM (STE, CODESTART, DTYPE, DEST);
end (*calculable*);
end (*TYPUA, TYPUJ, TYPUM*);
end (*if INCR <> 0*);
end (*with STK[STE]*);
end (*INCREMENT_DATUM*);
(** DATUM_PROCESSOR_CLASS: BINTVAL_TO_BJUMP PARMREG_TO_PARMSAVE INC_INDIRECTION TRANSLATE_LVLDSP **)
(**)
procedure BINTVAL_TO_BJUMP (STE : STKINX);
(*Convert the datum, which is a boolean in bintval form,
into bjump form.*)
var OPND : OPERAND;
SKIPLOC : AN_INSTREC; (*DATASTRCH*)
RESCODESTART : AN_INSTREC; (*DATASTRCH*)
begin
with STK[STE] do
begin
if not ((DTYPE=TYPUB) and (BREPRES=BINTVAL)) then
ASSERTFAIL('BINTVAL_T001');
GET_OPERAND (OPND, STE);
LOADSTACKEXCEPT (STE, STE);
if not RISFREE[S1RTB] and (RTBUSER <> STE) then
MOVE_AND_FREE_RTB;
FREEDATUMREGS (STE);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_EQL_Q, 0, OPND, ZERO_OP, nil);
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
FIXSOP (SKIPLOC, NEWINSTREC);
RESCODESTART := CODESTART;
STK[STE] := ZERODATUM;
CODESTART := RESCODESTART;
DTYPE := TYPUB;
NVPAS := 1; (*make it not look like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BREPRES := BJUMP;
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := true;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[STE] do*);
end (*BINTVAL_TO_BJUMP*);
procedure PARMREG_TO_PARMSAVE (STE : STKINX; PWORD : NONNEGINT);
(*If the datum contains references to parameter registers
logically preceding (but not including) parameter register
number 'PWORD', convert those references to the corresponding
location in the local parameter save area.*)
var P : integer;
begin
with CURPROCSPEC, STK[STE] do
if NVPAS >= 1 then if VPA1.VPA.WHICH = RGS then if
IS_PARMREG(VPA1.VPA.RGADR) then if
S1REG_TO_PRM[VPA1.VPA.RGADR] < PWORD then
begin
P := S1REG_TO_PRM[VPA1.VPA.RGADR];
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := CURLVL;
VPA1.VPA.MEMADR.DSPLMT := R_OFFSET + P*WORDUNITS;
if NVPAS>=2 then if VPA2.VPA.WHICH=RGS then if
IS_PARMREG(VPA2.VPA.RGADR) then if
S1REG_TO_PRM[VPA2.VPA.RGADR] < PWORD then
begin
P := S1REG_TO_PRM[VPA2.VPA.RGADR];
VPA2.VPA.WHICH := MEM;
VPA2.VPA.MEMADR.LVL := CURLVL;
VPA2.VPA.MEMADR.DSPLMT := R_OFFSET + P*WORDUNITS;
end;
end;
end (*PARMREG_TO_PARMSAVE*);
procedure INC_INDIRECTION(STE : STKINX; MAXFINALIND : INDIRECTION);
(*Increase the indirection on the datum at STK[STE] once
-- als/peg 19jul79.*)
begin
with STK[STE] do
begin
while FINALIND > MAXFINALIND do
SIMPLIFY (TOP);
if FPA.WHICH = RGS then ASSERTFAIL('INC_INDIR001');
if NVPAS = 0 then
begin (*move FPA to VPA*)
NVPAS := 1;
VPA1.VPAIND := IND1;
VPA1.VPA := FPA;
FPA := ZEROFPA;
end (*move FPA to VPA*)
else if (NVPAS=1) and (FPA=ZEROFPA) then
begin (*increase indirection on single VPA*)
if VPA1.VSHIFT<>0 then
ERROR (WINDEX_WITHOUT_BASE);
if VPA1.VPAIND = IND1 then VPA1.VPAIND := IND2
else FINALIND := succ(FINALIND);
end (*increase indirection on single VPA*)
else
(*the datum has multiple parts*)
FINALIND := succ(FINALIND);
end (*with STK[STE] do*);
end (*INC_INDIRECTION*);
procedure TRANSLATE_LVLDSP(var X : MEMOREG; MEMAREA : MEMTYPE);
(*Translates a U-Code (LVL,DSPLMT) into an S1 (LVL,DSPLMT) or an
S1REGISTER.*)
var TMPLVL : 0..MAXLVL;
begin
if not (X.WHICH = MEM) then ASSERTFAIL('TRANSL_LV001');
if not (X.MEMADR.LVL <= CURLVL) then ASSERTFAIL('TRANSL_LV002');
if not (X.MEMADR.DSPLMT mod QWBITS = 0) then ASSERTFAIL('TRANSL_LV003');
X.MEMADR.DSPLMT := X.MEMADR.DSPLMT div QWBITS;
TMPLVL := X.MEMADR.LVL;
if TMPLVL = 1 then
if MEMAREA = M_SPACE then
if X.MEMADR.DSPLMT < LASTFILBUF then
X.MEMADR.DSPLMT := X.MEMADR.DSPLMT + FILE_OFFSET
else X.MEMADR.DSPLMT := X.MEMADR.DSPLMT - L1FIRSTADDR + M_OFFSET
else ERROR(WNOT_IMPLEMENTED)
else if (TMPLVL = CURLVL) and (MEMAREA = R_SPACE)
and not PREGS_ARCHIVED then
begin (*map local parm into its register*)
X.RGADR := PRM_TO_S1REG[(X.MEMADR.DSPLMT) div WORDUNITS];
X.WHICH := RGS
end
else if MEMAREA in [R_SPACE, M_SPACE] then
case MEMAREA of
R_SPACE : X.MEMADR.DSPLMT := X.MEMADR.DSPLMT + R_OFFSET;
M_SPACE : X.MEMADR.DSPLMT := X.MEMADR.DSPLMT - FIRSTADDR + M_OFFSET
end (*case*)
else
ERROR(WNOT_IMPLEMENTED);
end (*TRANSLATE_LVLDSP*);
(** DATUM_PROCESSOR_CLASS: IS_SIMPLE FITS_SHRT_OFFSET FITS_SHORT_INDEX IS_CONSTANT IS_CNST_PLUS_OPND PUSHTOP POPTOP PUSH_STKFRAME POP_STKFRAME **)
(**)
function IS_SIMPLE (var V : VPAREC) : boolean;
(*Return true iff the VPA specifies an unshifted quantity
stored in a register.*)
begin
IS_SIMPLE := (V.VPAIND=IND1) and (V.VSHIFT=0)
and (V.VPA.WHICH=RGS);
end (*IS_SIMPLE*);
function FITS_SHRT_OFFSET (*(DISP : S1DISP) : boolean*);
(*Returns true iff the displacement is such that it
can be used in a short index.*)
begin
FITS_SHRT_OFFSET := (DISP mod WORDUNITS = 0)
and (MINSHORTOFFSET <= DISP div WORDUNITS)
and (DISP div WORDUNITS <= MAXSHORTOFFSET)
END (*FITS_SHRT_OFFSET*);
function FITS_SHORT_INDEX (var V : VPAREC) : boolean;
(*Returns true iff the VPA can be inserted as the
short index of an extended operand.*)
var D : INTEGER;
begin
if V.VPA.WHICH = RGS then FITS_SHORT_INDEX := true
else
begin
D := V.VPA.MEMADR.DSPLMT div WORDUNITS;
FITS_SHORT_INDEX := (V.VPAIND = IND1)
and (V.VPA.MEMADR.LVL > 0)
and (V.VPA.MEMADR.DSPLMT mod WORDUNITS = 0)
and (MINSHORTOFFSET <= D)
and (D <= MAXSHORTOFFSET)
end
end (*FITS_SHORT_INDEX*);
function IS_CONSTANT (*(STE : STKINX) : boolean*);
(*Return true iff datum represents a constant.*)
begin
with STK[STE] do
IS_CONSTANT := (FINALIND = IND0)
and (NVPAS = 0)
and (FPA.WHICH = MEM)
and (DTYPE <> TYPUM)
and ( (DTYPE <> TYPUB)
or (BREPRES = BINTVAL) )
and (FPA.MEMADR.LVL = 0);
end (*IS_CONSTANT*);
function IS_CNST_PLUS_OPND (STE : STKINX) : boolean;
(*Return true iff datum represents a nonzero constant plus
other parts which will fit in an operand if the constant
part is excluded.*)
begin
with STK[STE] do
IS_CNST_PLUS_OPND := (FINALIND = IND0)
and not (DTYPE in [TYPUB, TYPUM])
and (FPA.WHICH = MEM)
and (FPA.MEMADR.DSPLMT <> 0)
and ( (FPA.MEMADR.LVL=0) and (NVPAS=1)
and (VPA1.VSHIFT=0)
or (FPA.MEMADR.LVL<>0)
and (NVPAS=0) );
end (*IS_CNST_PLUS_OPND*);
procedure PUSHTOP;
(*Push an undefined datum onto the virtual stack,
checking for overflow.*)
begin
if TOP < MAXSTKINX then TOP := TOP + 1
else ERROR (WEXPR_TOO_COMPLEX);
end (*PUSHTOP*);
procedure POPTOP;
(*Pop the top value from the stack and discard it,
checking for underflow.*)
begin
if TOP >= BOT then TOP := TOP - 1
else ERROR (WPOP_OF_EMPTY_STACK);
end (*POPTOP*);
procedure PUSH_STKFRAME;
(*Push a new stack frame onto the virtual stack -- peg 13jul79.*)
begin
if CURFRAME >= MAXFRAME then ASSERTFAIL('PUSH_STKF001');
STKFRAME[CURFRAME] := BOT;
CURFRAME := CURFRAME + 1;
PUSHTOP; STK[TOP] := ZERODATUM;
BOT := TOP;
POPTOP;
end (*PUSH_STKFRAME*);
procedure POP_STKFRAME;
(*Pop a stack frame from the virtual stack -- peg 13jul79.*)
begin
if CURFRAME <= MINFRAME then ASSERTFAIL('POP_STKFR001');
CURFRAME := CURFRAME - 1;
BOT := STKFRAME[CURFRAME];
end (*POP_STKFRAME*);
(** LITERAL_TABLE_CLASS: UPD_REALTBL UPD_SETTBL UPD_PROCTBL **)
(**)
procedure UPD_REALTBL (var DISP : S1DISP; RVAL : real);
(*Add the real to the real table if not already there. Return
its table displacement in DISP.*)
var FOUND : boolean;
PTR : A_CODEREC;
W : S1WORD;
begin
FOUND := false;
DISP := 0;
PTR := REALTBL.FIRST;
REAL_TO_S1WORD (W, RVAL);
while not FOUND and (PTR <> nil) do
if (PTR↑.CODEWORD = W) then
FOUND := true
else
begin
PTR := PTR↑.NEXTPTR↑.NEXTPTR;
DISP := DISP + WORDUNITS;
end;
if not FOUND then
begin
EMIT_S1WORD (REALTBL, W);
end;
end (*UPD_REALTBL*);
procedure UPD_SETTBL (var DISP : S1DISP; SVAL : SETREP);
(*Add the entire set to the set table if not already there.*)
var FOUND : boolean;
PTR : A_CODEREC; (*setch...*)
CNT : 0..S1SETREP_SIZE;
INDEX : S1SETREP_INDEX;
S1SET : S1SETREP; (*...setch*)
begin
FOUND := false;
DISP := 0;
PTR := SETTBL.FIRST;
SETREP_TO_S1WORDS (S1SET, SVAL); (*setch*)
while not FOUND and (PTR <> nil) do
begin (*setch...*)
CNT := 0;
for INDEX := 0 to S1SETREP_MAX do
begin
if PTR↑.CODEWORD = S1SET[INDEX] then CNT := CNT + 1;
PTR := PTR↑.NEXTPTR;
end;
if CNT = S1SETREP_SIZE then FOUND := true
else DISP := DISP + S1SETREP_SIZE*WORDUNITS;
end (*while*);
if not FOUND then
for INDEX := 0 to S1SETREP_MAX do
EMIT_S1WORD(SETTBL, S1SET[INDEX]); (*...setch*)
end (*UPD_SETTBL*);
procedure UPD_PROCTBL (var FIXPTR : A_PROCENT; var PID : ALFA);
(*Add the name in PID to the proc table if not already there and
return a pointer to the entry for fixup purposes.*)
var PTR : A_PROCENT;
begin
if PROCTBL.FIRST = nil then
begin
new (PROCTBL.FIRST);
with PROCTBL.FIRST↑ do
begin
NAME := PID; FIXLIST := EMPTYOPNDXWORDFIXLIST; NEXTPTR := nil;
end; (*DATASTRCH*)
PROCTBL.NPROCS := 1;
FIXPTR := PROCTBL.FIRST;
end
else
begin (*non-empty table*)
PTR := PROCTBL.FIRST;
while (PTR↑.NEXTPTR <> nil) and (PTR↑.NAME <> PID) do
PTR := PTR↑.NEXTPTR;
if PTR↑.NAME = PID then FIXPTR := PTR
else
begin (*add at end*)
new (PTR↑.NEXTPTR);
with PTR↑.NEXTPTR↑ do
begin
NAME := PID;
FIXLIST := EMPTYOPNDXWORDFIXLIST; (*DATASTRCH*)
NEXTPTR := nil;
end;
PROCTBL.NPROCS := PROCTBL.NPROCS + 1;
FIXPTR := PTR↑.NEXTPTR;
end (*add at end*);
end (*non-empty table*);
end (*UPD_PROCTBL*);
(** LITERAL_TABLE_CLASS: UPD_LBLTBL UPD_BOUNDTBL **)
(**)
procedure UPD_LBLTBL (*(var LPTR : A_LBLHASHENT; LNUM : LBL_INDEX;
LCLASS : LINTVAL_OR_LINSTPTR)*); (*DATADTRCH*)
(*Add an entry for this label to the label hash table if one is not
already there. Return in LPTR a pointer to the entry.*)
var H : RNG_0_LBLHTSIZEM1;
PTR : A_LBLHASHENT;
FOUND : boolean;
begin
H := LABELHASH (LNUM);
PTR := LBLHASHTAB[H];
FOUND := false;
while not FOUND and (PTR <> nil) do
if PTR↑.LBLNUM = LNUM then FOUND := true
else PTR := PTR↑.NEXTPTR;
if FOUND then LPTR := PTR
else
begin (*add to front*)
new (PTR);
PTR↑.NEXTPTR := LBLHASHTAB[H];
LBLHASHTAB[H] := PTR;
PTR↑.LBLNUM := LNUM;
PTR↑.DEFINED := false;
case LCLASS of
LINTVAL : PTR↑.CLIST := EMPTYOPND2FIXLIST; (*DATASTRCH*)
LINSTPTR :
begin
PTR↑.JLIST := EMPTYJUMPLIST;
PTR↑.JUMPTABLELABEL := false
end
end (*case*);
LPTR := PTR;
end (*add to front*);
end (*UPD_LBLTBL*);
procedure UPD_BOUNDTBL (var DISP : S1DISP; LOW, HI : integer;
BNDTYP : OPNDTYPE);
(*Add the bound triple to the bound table if not already there.
Return its table displacement in DISP.*)
var FOUND : boolean;
PTR : A_CODEREC;
W1, W2, W3 : S1WORD;
begin
INTEGER_TO_S1WORD (W1, LOW);
INTEGER_TO_S1WORD (W2, HI);
W3 := ZEROS1WORD;
PUTFIELD (W3, BNDTYP_START, BNDTYP_LEN, ord(TYPECODE[BNDTYP]) );
PTR := BOUNDTBL.FIRST;
DISP := 0;
FOUND := false;
while not FOUND and (PTR <> nil) do
if (PTR↑.CODEWORD = W1) and (PTR↑.NEXTPTR↑.CODEWORD = W2) and
(PTR↑.NEXTPTR↑.NEXTPTR↑.CODEWORD = W3) then
FOUND := true
else
begin
PTR := PTR↑.NEXTPTR↑.NEXTPTR↑.NEXTPTR;
DISP := DISP + 3*WORDUNITS;
end;
if not FOUND then
begin
EMIT_S1WORD (BOUNDTBL, W1);
EMIT_S1WORD (BOUNDTBL, W2);
EMIT_S1WORD (BOUNDTBL, W3);
end;
end (*UPD_BOUNDTBL*);
(** GET_OPERAND_CLASS: INSERT_SHORT_VPA VPA_OPERAND_NOSHIFT FIT_IN_OPERAND **)
(**)
procedure INSERT_SHORT_VPA (var OPND : OPERAND;
var V : VPAREC);
(*Insert the VPA into the operand as a short index,
including shift, without changing the rest of
the operand.*)
begin
if not (FITS_SHORT_INDEX(V) and (OPND.X = 1) ) then
ASSERTFAIL('INS_SH_VP001');
if V.VPA.WHICH = RGS then
begin
if V.VPAIND = IND1 then
begin
OPND.REG := 0; OPND.F := V.VPA.RGADR
end
else
begin
OPND.REG := V.VPA.RGADR; OPND.F := 0
end
end (*register*)
else
begin (*short mem*)
OPND.REG := LVL_TO_S1REG [V.VPA.MEMADR.LVL];
OPND.F := V.VPA.MEMADR.DSPLMT div WORDUNITS
end (*short mem*);
OPND.XW.S := V.VSHIFT
end (*INSERT_SHORT_VPA*);
procedure VPA_OPERAND_NOSHIFT(var OPND : OPERAND; var V : VPAREC);
(*Construct an operand specifying the VPA, including indirection
but not including shift. Operand may be short or extended.*)
begin
if V.VPA.WHICH = RGS then
begin
OPND := EMPTY_OP;
OPND.X := 0;
if V.VPAIND = IND1 then
begin
OPND.REG := 0; OPND.F := V.VPA.RGADR
end
else
begin
OPND.REG := V.VPA.RGADR; OPND.F := 0
end
end (*register*)
else if FITS_SHRT_OFFSET(V.VPA.MEMADR.DSPLMT)
and (V.VPA.MEMADR.LVL > 0) then
begin
if V.VPAIND = IND2 then
ADDR_OPERAND (OPND, 0)
else
begin
OPND := EMPTY_OP;
OPND.X := 0
end;
OPND.REG := LVL_TO_S1REG [V.VPA.MEMADR.LVL];
OPND.F := V.VPA.MEMADR.DSPLMT div WORDUNITS
end (*short offset*)
else
begin (*extended address*)
if V.VPA.MEMADR.LVL = 0 then
ADDR_OPERAND (OPND, V.VPA.MEMADR.DSPLMT)
else
XTNDED_REGDISP_OPERAND (OPND,
LVL_TO_S1REG [V.VPA.MEMADR.LVL],
V.VPA.MEMADR.DSPLMT);
if V.VPAIND = IND2 then OPND.XW.I := 1
end (*extended address*)
end (*VPA_OPERAND_NOSHIFT*);
procedure FIT_IN_OPERAND (*(var TOO_COMPLICATED : boolean;
var OPND : OPERAND; STE : STKINX)*);
(*Build an operand accessing the quantity described by the datum if
this is possible without emitting any code. Return
TOO_COMPLICATED = true if this was impossible, false
otherwise.*)
begin
TOO_COMPLICATED := false;
with STK[STE] do
begin
if not (FPA.WHICH = MEM) then ASSERTFAIL('FIT_IN_OP001');
if DTYPE = TYPUM then TOO_COMPLICATED := true
else if IS_CONSTANT(STE) then
begin
if not (FINALIND = IND0) then ASSERTFAIL('FIT_IN_OP002');
if DTYPE in [TYPUJ,TYPUL,TYPUB,TYPUC] then
IMM_OPERAND (OPND, FPA.MEMADR.DSPLMT)
else if DTYPE in [TYPUI, TYPUK] then
begin
ERROR(WNOT_IMPLEMENTED);
% XTNDED_IMM_OPERAND (OPND, FPA.MEMADR.DSPLMT);
OPND.F := 1; (*integer sign extend*) \
end
else if DTYPE = TYPUA then
begin
if (FPA.MEMADR.DSPLMT < 0) or
(FPA.MEMADR.DSPLMT > MAXS1ADDR) then
ERROR (WADDR_OUT_OF_RANGE);
IMM_OPERAND (OPND, FPA.MEMADR.DSPLMT)
end (*TYPUA*)
else if DTYPE = TYPUQ then
ERROR(WNOT_IMPLEMENTED)
else if DTYPE = TYPUR then
REAL_IMM_OPERAND (OPND, RCNST) (*LCW*)
else if DTYPE = TYPUS then
begin
XTNDED_REGDISP_OPERAND
(OPND, S1RPC, 0);
OPND.FIXUP := SETFIX;
(*setch*) UPD_SETTBL (OPND.XW.DISP, SCNST);
end (*TYPUS*)
else if DTYPE = TYPUN then
IMM_OPERAND (OPND, NILVAL)
else if not (false) then ASSERTFAIL('FIT_IN_OP003');
end (*constant*)
else if FINALIND = IND0 then
case NVPAS of
(*NVPAS = *) 0:
if FPA.MEMADR.DSPLMT = 0 then
REG_OPERAND (OPND,
LVL_TO_S1REG[FPA.MEMADR.LVL])
else TOO_COMPLICATED := true;
(*NVPAS = *) 1:
if (VPA1.VSHIFT=0) and (FPA=ZEROFPA) then
VPA_OPERAND_NOSHIFT (OPND, VPA1)
else TOO_COMPLICATED := true;
(*NVPAS = *) 2:
TOO_COMPLICATED := true;
end (*case NVPAS of*)
else
begin (*FINALIND > IND0*)
if not ( NVPAS > 0) then ASSERTFAIL('FIT_IN_OP004');
if (FPA.MEMADR.LVL=0) and
(NVPAS=1) and IS_SIMPLE(VPA1) then
begin (*non-level register and displacement*)
if FINALIND = IND1 then
REGDISP_OPERAND (OPND, VPA1.VPA.RGADR,
FPA.MEMADR.DSPLMT)
else if FITS_SHRT_OFFSET(FPA.MEMADR.DSPLMT) then
begin
ADDR_OPERAND (OPND, 0);
OPND.REG := VPA1.VPA.RGADR;
OPND.F := FPA.MEMADR.DSPLMT div WORDUNITS
end
else
begin
XTNDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
OPND.XW.I := 1
end
end (*non-level register and displacement*)
else
begin (*more complicated*)
if NVPAS = 1 then
(*NVPAS = 1*)
begin
if not FITS_SHORT_INDEX(VPA1) then
TOO_COMPLICATED := true
else
begin
if FPA.MEMADR.LVL > 0 then
XTNDED_REGDISP_OPERAND (OPND,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
else
ADDR_OPERAND (OPND, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1);
end
end (*NVPAS = 1*)
else
(*NVPAS = 2*)
if FPA.MEMADR.LVL > 0 then
TOO_COMPLICATED := true
else if IS_SIMPLE(VPA2) and
FITS_SHORT_INDEX(VPA1) then
begin
XTNDED_REGDISP_OPERAND (OPND,
VPA2.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1)
end
else if IS_SIMPLE(VPA1) and
FITS_SHORT_INDEX(VPA2) then
begin
XTNDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA2)
end
else
TOO_COMPLICATED := true;
if FINALIND = IND2 then OPND.XW.I := 1;
end (*more complicated*)
end (*FINALIND > IND0*);
end (*with STK[STE] do*);
end (*FIT_IN_OPERAND*);
(** GET_OPERAND_CLASS: FIT_ADDRESS_IN_OPERAND **)
(**)
procedure FIT_ADDRESS_IN_OPERAND (var TOO_COMPLICATED : boolean;
var OPND : OPERAND; STE : STKINX);
(*Build an operand accessing the location whose address is the
quantity (of type address) described by the datum, if this is
possible without emitting any code. Return TOO_COMPLICATED =
true if this was impossible, false otherwise.*)
begin
TOO_COMPLICATED := false;
with STK[STE] do
begin
if (DTYPE=TYPUM) or (FINALIND>IND1) then
TOO_COMPLICATED := true
else
case NVPAS of
(*NVPAS = *) 0:
begin
if not ( FINALIND = IND0) then ASSERTFAIL('FIT_ADDR 001');
if FPA.WHICH = RGS then
REG_OPERAND (OPND, FPA.RGADR)
else if FPA.MEMADR.LVL = 0 then
ADDR_OPERAND (OPND, FPA.MEMADR.DSPLMT)
else
REGDISP_OPERAND (OPND,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
end (*NVPAS = 0*);
(*NVPAS = *) 1:
begin
if (FPA.MEMADR.LVL = 0) and IS_SIMPLE(VPA1) then
begin (*non-level register and displacement*)
if FINALIND = IND0 then
REGDISP_OPERAND (OPND, VPA1.VPA.RGADR,
FPA.MEMADR.DSPLMT)
else if FITS_SHRT_OFFSET(FPA.MEMADR.DSPLMT) then
begin
ADDR_OPERAND (OPND, 0);
OPND.REG := VPA1.VPA.RGADR;
OPND.F := FPA.MEMADR.DSPLMT div WORDUNITS;
end
else
begin
XTNDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
OPND.XW.I := 1;
end;
end (*non-level register and displacement*)
else if FITS_SHORT_INDEX(VPA1) then
begin
if FPA.MEMADR.LVL = 0 then
ADDR_OPERAND (OPND, FPA.MEMADR.DSPLMT)
else
XTNDED_REGDISP_OPERAND (OPND,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1);
if FINALIND = IND1 then OPND.XW.I := 1
end
else if (FINALIND=IND0) and (FPA=ZEROFPA) and
(VPA1.VSHIFT=0) and (VPA1.VPAIND=IND1) then
begin
VPA_OPERAND_NOSHIFT (OPND, VPA1);
if not ( OPND.X = 1) then ASSERTFAIL('FIT_ADDR 002');
OPND.XW.I := 1;
end
else
TOO_COMPLICATED := true;
end (*NVPAS = 1*);
(*NVPAS = *) 2:
begin
if FPA.MEMADR.LVL > 0 then
TOO_COMPLICATED := true
else if IS_SIMPLE(VPA1)
and FITS_SHORT_INDEX(VPA2) then
begin
XTNDED_REGDISP_OPERAND (OPND,
VPA1.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA2);
if FINALIND = IND1 then OPND.XW.I := 1;
end
else if IS_SIMPLE(VPA2)
and FITS_SHORT_INDEX(VPA1) then
begin
XTNDED_REGDISP_OPERAND (OPND,
VPA2.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND, VPA1);
if FINALIND = IND1 then OPND.XW.I := 1;
end
else
TOO_COMPLICATED := true
end (*NVPAS = 2*)
end (*case NVPAS*)
end (*with STK[STE] do*);
end (*FIT_ADDRESS_IN_OPERAND*);
(** GET_OPERAND_CLASS: GET_OPERAND GET_SHORT_OPERAND GET_ADDRESS **)
(**)
procedure GET_OPERAND (*(var OPND : OPERAND; STE : STKINX)*);
(*Build an operand which accesses the quantity described
by the datum in STK[STE], simplifying the datum as
necessary.*)
var TOO_COMPLICATED : boolean;
begin
if STK[STE].DTYPE = TYPUB then
if STK[STE].BREPRES = BJUMP then BJUMP_TO_BINTVAL (STE);
FIT_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
while TOO_COMPLICATED do
begin
SIMPLIFY (STE);
FIT_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
end;
if STK[STE].DTYPE = TYPUS then (*setch*)
TWIDDLE_OPERAND(OPND, WHICHPART*DOUBLEWORDUNITS);(*setch*)
end (*GET_OPERAND*);
procedure GET_SHORT_OPERAND (var OPND : OPERAND; STE : STKINX);
(*Build a short operand which accesses the quantity described
by the datum, simplifying as necessary.*)
var OPNDR : OPERAND;
begin
GET_OPERAND (OPND, STE);
if OPND.X = 1 then
begin (*generate a MOV*)
FREEDATUMREGS (STE);
if STK[STE].DTYPE = TYPUS then (*peg 27sep79...*)
FINDRGBLOCK(S1SETREP_SIZE)
else if IS_DOUBLE[STK[STE].DTYPE] then FINDRP else FINDRG; (*...peg 27sep79*)
REG_OPERAND (OPNDR, NXTRG);
EMITXOP (MOV_X_X[STK[STE].DTYPE], OPNDR, OPND);
REG_DATUM (STE, STK[STE].CODESTART,
STK[STE].DTYPE, NXTRG);
OPND := OPNDR;
end (*generate a MOV*);
end (*GET_SHORT_OPERAND*);
procedure GET_ADDRESS (var OPND : OPERAND; STE : STKINX);
(*The datum describes a quantity of type address. Build an
operand accessing the location with that address,
simplifying the datum as necessary. (Approximately
GET_OPERAND with one more level of indirection
on the datum) *)
var TOO_COMPLICATED : boolean;
begin
FIT_ADDRESS_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
while TOO_COMPLICATED do
begin
SIMPLIFY (STE);
FIT_ADDRESS_IN_OPERAND (TOO_COMPLICATED, OPND, STE);
end
end (*GET_ADDRESS*);
(** GET_OPERAND_CLASS: MOVE_QUANTITY SLR_QUANTITY COERCE_AND_MOVE_QUANTITY STORE **)
(**)
procedure MOVE_QUANTITY (*(var DEST : OPERAND; STE : STKINX)*);
(*Emit code to calculate the datum and move to location given
by operand. Do *Not* change datum to reflect move, but
simplification changes may take place.*)
var SOURCE : OPERAND;
TOOMUCH : boolean;
begin
with STK[STE] do
if (DTYPE=TYPUA) and (FINALIND=IND0) then
begin
(*This attempts to optimize the case of an unindirected
address, without going to a lot of work. To do it
right every time would require a loop here like
the loops in the integer arithmetic instructions.*)
FIT_IN_OPERAND (TOOMUCH, SOURCE, STE);
if TOOMUCH then
begin
GET_ADDRESS (SOURCE, STE);
EMITXOP (XMOV_A, DEST, SOURCE);
end
else
EMITXOP (XMOV_S_S, DEST, SOURCE)
end
else
begin
GET_OPERAND (SOURCE, STE);
if DEST<>SOURCE then
EMITXOP (MOV_X_X[DTYPE], DEST, SOURCE);
end;
end (*MOVE_QUANTITY*);
procedure SLR_QUANTITY (DEST : OPERAND; REGNUM : S1REGISTER;
STE : STKINX);
(*Emit code to calculate the datum and load it into register REGNUM
while saving the previous contents of the register in the word
specified by the operand, using the SLR.'REGNUM' instruction.
Do *Not* change the datum to reflect the move, but
simplification changes may take place.*)
var SOURCE : OPERAND;
TOOMUCH : boolean;
begin
with STK[STE] do
if (DTYPE=TYPUA) and (FINALIND=IND0) then
begin
(*This attempts to optimize the case of an unindirected
address, without going to a lot of work. To do it
right every time would require a loop here like
the loops in the integer arithmetic instructions.*)
FIT_IN_OPERAND (TOOMUCH, SOURCE, STE);
if TOOMUCH then
begin
GET_ADDRESS (SOURCE, STE);
EMITXOP (SLRADR_N[REGNUM], DEST, SOURCE);
end
else
EMITXOP (SLR_N[REGNUM], DEST, SOURCE)
end
else
begin
GET_OPERAND (SOURCE, STE);
EMITXOP (SLR_N[REGNUM], DEST, SOURCE);
end;
end (*SLR_QUANTITY*);
procedure COERCE_AND_MOVE_QUANTITY (var DEST : OPERAND;
STE : STKINX; RESTYPE : OPNDTYPE);
(*Get the datum to the location specified by the operand,
coercing it to type RESTYPE. Do *Not* change datum to
reflect coercion, but simplification changes may occur.*)
var SOURCE : OPERAND;
MOVEOP : S1OPCODE;
TOOMUCH : boolean;
begin
with STK[STE] do
if (DTYPE = TYPUA) and (RESTYPE = TYPUA)
and (FINALIND = IND0) then
begin
(*This attempts to optimize the case of an unindirected
address, without going to a lot of work. To do it
right every time would require a loop here like
the loops in the integer arithmetic instructions.*)
FIT_IN_OPERAND (TOOMUCH, SOURCE, STE);
if TOOMUCH then
begin
GET_ADDRESS (SOURCE, STE);
EMITXOP (XMOV_A, DEST, SOURCE);
end
else
EMITXOP (XMOV_S_S, DEST, SOURCE)
end
else
begin
GET_OPERAND (SOURCE, STE);
if not EQUAL_OPERANDS(DEST, SOURCE) or (DTYPE <> RESTYPE)
then
begin (*Use ordinary MOV*)
MOVEOP := MOV_X_Y[RESTYPE, DTYPE];
if MOVEOP = XILLEGAL then
ERROR (WCOERCION_INVALID);
EMITXOP (MOVEOP, DEST, SOURCE);
end;
end (*Use ordinary MOV*);
end (*COERCE_AND_MOVE_QUANTITY*);
procedure STORE(DEST, SOURCE : STKINX);
(*For the future, consider doing STORE without always using
a MOV: (apropos for peephole).*)
(*Emit code to store the operand represented by SOURCE at the
address represented by DEST.*)
var OPND1 (*,OPND2*) : OPERAND;
MOVEOP : S1OPCODE;
begin
MOVEOP := MOV_X_Y[TYP,STK[SOURCE].DTYPE];
if MOVEOP = XILLEGAL then ERROR(WINCOMPATIBLE_TYPES);
(*Possible optimizing heuristic: GET_OPERAND before GET_ADDRESS*)
GET_ADDRESS(OPND1,DEST);
COERCE_AND_MOVE_QUANTITY(OPND1,SOURCE,TYP)
(*or, GET_OPERAND(OPND2,SOURCE); EMITXOP(MOVEOP,OPND1,OPND2)*)
end (*STORE*);
(** SIMPLIFY_CLASS: ADD_SUB_SINGLE INC_OR_DEC ADD_TOP_TWO_DATUMS MULT_SINGLE SIMPLIFY ADD_VPAS FPA_LVL_PLUS_VPA1 FPA_DSPLMT_PLUS_VPA1 VPA_FPA_FINALIND SHORT_AND_REG CALCULATE_FPA DEREF_AND_SHIFT SHIFT_VPA1 DEREF DEREF_TO_END **)
(**)
procedure ADD_SUB_SINGLE (*(var DEST : S1REGISTER; ADDOP : S1OPCODE;
var OPND1, OPND2 : OPERAND; STE : STKINX)*);
(*Add together the two singleword operands, optimizing
to INC or DEC if possible.*)
procedure INC_OR_DEC (INC : integer; var OPND : OPERAND);
var OPNDR : OPERAND;
ADDOP : S1OPCODE;
begin
if INC=1 then ADDOP:=XINC_S else ADDOP:=XDEC_S;
if IS_T_REG(OPND) then DEST := OPND.F (*14FEB79 PTZ*)
else
begin
FINDRG; DEST := NXTRG
end;
REG_OPERAND (OPNDR, DEST);
EMITXOP (ADDOP, OPNDR, OPND);
end (*INC_OR_DEC*);
begin (*ADD_SUB_SINGLE*)
if ISSHORTCONST(OPND1) and ((OPND1.F=1) or (OPND1.F=-1)) (*EJG 14FEB79*)
and (ADDOP=XADD_S) then INC_OR_DEC(OPND1.F, OPND2) (*EJG 14FEB79*)
else if ISSHORTCONST(OPND2) and ((OPND2.F=1) or (OPND2.F=-1)) then
if ADDOP=XADD_S then INC_OR_DEC(OPND2.F, OPND1)
else INC_OR_DEC(-OPND2.F, OPND1)
else
ALLOC_AND_EMIT_TOP (DEST, ADDOP, OPND1, OPND2,
false, false, false, STE);
end (*ADD_SUB_SINGLE*);
procedure ADD_TOP_TWO_DATUMS;
(*Add the top two singlewords (integer or address) on the
stack by combining and/or emitting code. Sets DTYPE and
CODESTART in the resultant datum.*)
var COMBINABLE, ADDABLE, TOOMUCH1, TOOMUCH2 : boolean;
CONSTPART : integer;
OPND1, OPND2 : OPERAND;
UNSIMPLE, SIMPLER : STKINX;
DEST : S1REGISTER;
RESTYPE : OPNDTYPE;
begin
COMBINABLE := false;
ADDABLE := false;
repeat
if (STK[TOP].NVPAS=0) and (STK[TOP].FPA=ZEROFPA)
and (STK[TOP].DTYPE<>TYPUM) then
COMBINABLE := true
else if (STK[TOP-1].NVPAS=0) and (STK[TOP-1].FPA=ZEROFPA)
and (STK[TOP-1].DTYPE<>TYPUM) then
COMBINABLE := true
else
if (STK[TOP].FINALIND=IND0)
and (STK[TOP-1].FINALIND=IND0)
and ( ((STK[TOP].FPA.MEMADR.LVL=0) and (STK[TOP].DTYPE<>TYPUM))
or ((STK[TOP-1].FPA.MEMADR.LVL=0) and (STK[TOP-1].DTYPE<>TYPUM)) )
and (STK[TOP].NVPAS + STK[TOP-1].NVPAS <= 2) then
COMBINABLE := true
else
begin (*not combinable*)
if (STK[TOP].FINALIND = IND0) and
(STK[TOP-1].FINALIND = IND0) then
begin
CONSTPART := STK[TOP].FPA.MEMADR.DSPLMT
+ STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP].FPA.MEMADR.DSPLMT := 0;
STK[TOP-1].FPA.MEMADR.DSPLMT := 0;
end
else
CONSTPART := 0;
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not TOOMUCH1 and not TOOMUCH2 then
ADDABLE := true
else
begin (*must simplify*)
if not TOOMUCH1 then
begin
UNSIMPLE := TOP;
SIMPLER := TOP-1;
end
else if not TOOMUCH2 then
begin
UNSIMPLE := TOP-1;
SIMPLER := TOP;
end
else
begin (*Pick one at random*)
UNSIMPLE := TOP;
SIMPLER := TOP-1;
end;
if CONSTPART <> 0 then
begin
if not ((STK[UNSIMPLE].FINALIND = IND0) and
(STK[UNSIMPLE].FPA.MEMADR.DSPLMT = 0) ) then
ASSERTFAIL('ADD_TOP_T001');
STK[UNSIMPLE].FPA.MEMADR.DSPLMT := CONSTPART;
end;
SIMPLIFY (UNSIMPLE);
end (*must simplify*);
end (*not combinable*)
until COMBINABLE or ADDABLE;
if (STK[TOP-1].DTYPE=TYPUM) or (STK[TOP].DTYPE=TYPUM) then
RESTYPE := TYPUM
else if (STK[TOP-1].DTYPE=TYPUA) or (STK[TOP].DTYPE=TYPUA) then
RESTYPE := TYPUA
else if (STK[TOP-1].DTYPE=TYPUL) and (STK[TOP].DTYPE=TYPUL) then
RESTYPE := TYPUL
else RESTYPE := TYPUJ;
if ADDABLE then
begin (*ADDABLE*)
if RESTYPE in [TYPUJ, TYPUL] then
begin
COERCE_INT_DATUM(TOP-1);
COERCE_INT_DATUM(TOP);
end (*TYPUJ, TYPUL*);
ADD_SUB_SINGLE (DEST, XADD_S, OPND1, OPND2, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, STK[TOP].CODESTART, RESTYPE, DEST);
STK[TOP].DTYPE := RESTYPE;
end (*ADDABLE*)
else
begin (*COMBINABLE*)
if (STK[TOP-1].NVPAS=0) and
(STK[TOP-1].FPA=ZEROFPA) and (STK[TOP-1].DTYPE<>TYPUM) then
STK[TOP-1] := STK[TOP]
else if (STK[TOP].NVPAS=0) and
(STK[TOP].FPA=ZEROFPA) and (STK[TOP].DTYPE<>TYPUM) then
(*Top is zero so just throw it away.*)
else
begin (*Both datums have FINALIND = IND0.*)
if STK[TOP].FPA.MEMADR.LVL<>0 then
STK[TOP-1].FPA.MEMADR.LVL := STK[TOP].FPA.MEMADR.LVL;
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP].FPA.MEMADR.DSPLMT + STK[TOP-1].FPA.MEMADR.DSPLMT;
if STK[TOP-1].NVPAS = 0 then
begin
if STK[TOP].NVPAS > 0 then
STK[TOP-1].VPA1 := STK[TOP].VPA1;
if STK[TOP].NVPAS = 2 then
STK[TOP-1].VPA2 := STK[TOP].VPA2;
end
else if (STK[TOP-1].NVPAS=1) and (STK[TOP].NVPAS=1) then
STK[TOP-1].VPA2 := STK[TOP].VPA1;
STK[TOP-1].NVPAS := STK[TOP-1].NVPAS+STK[TOP].NVPAS;
end (*Both datums have FINALIND = IND0*);
if RTBUSER = TOP then RTBUSER := TOP-1;
POPTOP;
end (*COMBINABLE*);
end (*ADD_TOP_TWO_DATUMS*);
procedure MULT_SINGLE (var DEST : S1REGISTER;
var OPND1, OPND2 : OPERAND; STE : STKINX);
(*Multiply together the two singleword operands, optimizing to
shift if possible. Note that because of negatives, a right
shift is *Not* equivalent to a divide.*)
(*Note - at present this procedure only considers short
constants for possible translations into shifts.
When real S1WORDs make it easier to consider extended
constants, this should be improved.*)
var SHIFTDIST : integer;
OPNDI : OPERAND;
begin
if ISSHORTCONST(OPND1) then
begin
SHIFTDIST := POWER2 (OPND1.F);
if SHIFTDIST >= 0 then
begin
IMM_OPERAND (OPNDI, SHIFTDIST);
ALLOC_AND_EMIT_TOP (DEST, XSHFA_LF_S, OPND2, OPNDI,
false, false, false, STE);
end
else
ALLOC_AND_EMIT_TOP (DEST, XMULT_S, OPND1, OPND2,
false, false, false, STE);
end
else if ISSHORTCONST(OPND2) then
begin
SHIFTDIST := POWER2 (OPND2.F);
if SHIFTDIST >= 0 then
begin
IMM_OPERAND (OPNDI, SHIFTDIST);
ALLOC_AND_EMIT_TOP
(DEST, XSHFA_LF_S, OPND1, OPNDI,
false, false, false, STE);
end
else
ALLOC_AND_EMIT_TOP (DEST, XMULT_S, OPND1, OPND2,
false, false, false, STE);
end
else
ALLOC_AND_EMIT_TOP (DEST, XMULT_S, OPND1, OPND2,
false, false, false, STE);
end (*MULT_SINGLE*);
procedure SIMPLIFY (*(STE : STKINX)*);
(*By doing a very small amount of work - about one instruction -
simplify the datum so that it is closer to fitting in an
operand. Repeated calls to this procedure are guaranteed to
eventually get it so it will fit. One more call will get the
quantity into a register if it is not a constant: beyond this
point it is an error to call SIMPLIFY.*)
var OPND : OPERAND;
UNKNOWN_LOC : integer;
procedure ADD_VPAS;
(*Build operands for VPA1 and VPA2, both of which have zero
shifts. Generate an ADD instruction to combine the two
into a simple register. This is guaranteed not to
completely sum the parts of the datum if the datum is
an address.*)
var OPND1, OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((VPA1.VSHIFT=0) and (VPA2.VSHIFT=0)) then
ASSERTFAIL('ADD_VPAS 001');
if not ((FINALIND>IND0) or (DTYPE in [TYPUA,TYPUM,TYPUJ,TYPUL])) then
ASSERTFAIL('ADD_VPAS 002');
VPA_OPERAND_NOSHIFT (OPND1, VPA1);
VPA_OPERAND_NOSHIFT (OPND2, VPA2);
ALLOC_AND_EMIT_TOP (DEST, XADD_S, OPND1, OPND2,
false, false, false, STE);
FREVPARGUNLESS (VPA1, DEST);
FREVPARGUNLESS (VPA2, DEST);
VPA1 := ZEROVPA; VPA2 := ZEROVPA;
NVPAS := 1;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST;
end (*with STK[STE]*)
end (*ADD_VPAS*);
procedure FPA_LVL_PLUS_VPA1 (var OPND : OPERAND);
(*OPND describes VPA1. Emit an ADD instruction to
combine this with the FPA level, replacing them
by a simple register. This is guaranteed not to
completely sum the parts of the datum.*)
var OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((FPA.MEMADR.LVL > 0) and
((DTYPE=TYPUA) or (FINALIND>IND0)) ) then
ASSERTFAIL('FPLVL_VPA001');
REG_OPERAND (OPND2, LVL_TO_S1REG [FPA.MEMADR.LVL] );
ALLOC_AND_EMIT_TOP (DEST, XADD_S, OPND, OPND2,
false, false, false, STE);
FREVPARGUNLESS (VPA1, DEST);
VPA1 := ZEROVPA;
FPA.MEMADR.LVL := 0;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST;
end (*with STK[STE]*)
end (*FPA_LVL_PLUS_VPA1*);
procedure FPA_DSPLMT_PLUS_VPA1 (var OPND : OPERAND);
(*OPND describes VPA1. Emit an ADD instruction
to add this VPA to the FPA displacement,
resulting in a single register VPA.*)
var OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((FINALIND=IND0) and
(*peg 18sep79*) (DTYPE in [TYPUB, TYPUC, TYPUJ, TYPUL])) then
ASSERTFAIL('FDSP_VPA 001');
IMM_OPERAND (OPND2, FPA.MEMADR.DSPLMT);
ADD_SUB_SINGLE (DEST, XADD_S, OPND, OPND2, STE);
FREVPARGUNLESS (VPA1, DEST);
FPA.MEMADR.DSPLMT := 0;
VPA1 := ZEROVPA;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST
end (*with STK[STE]*)
end (*FPA_DSPLMT_PLUS_VPA1*);
procedure VPA_FPA_FINALIND;
(*The datum consists of a short-index VPA and an FPA,
with some value of FINALIND. Completely simplify it
using address arithmetic into a single register.*)
var OPND1, OPND2 : OPERAND;
MOVEOP : S1OPCODE;
begin
with STK[STE] do
if IS_SIMPLE(VPA1) and (DTYPE<>TYPUM)
and (FPA.MEMADR.LVL = 0)
and FITS_SHRT_OFFSET (FPA.MEMADR.DSPLMT) then
begin (*non-level register and short offset*)
if FINALIND = IND2 then
begin
ADDR_OPERAND (OPND2, 0);
OPND2.REG := VPA1.VPA.RGADR;
OPND2.F := FPA.MEMADR.DSPLMT div WORDUNITS;
FREEDATUMREGS (STE);
MOVEOP := MOV_X_X[DTYPE];
(*peg 27sep79*) if DTYPE = TYPUS then
(*peg 27sep79*) FINDRGBLOCK(S1SETREP_SIZE)
(*peg 27sep79*) else if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
end
else
begin
REGDISP_OPERAND (OPND2, VPA1.VPA.RGADR,
FPA.MEMADR.DSPLMT);
FREEDATUMREGS (STE);
if FINALIND = IND0 then
begin MOVEOP := XMOV_A; FINDRG; end
else
begin
MOVEOP := MOV_X_X[DTYPE];
(*peg 27sep79*) if DTYPE = TYPUS then
(*peg 27sep79*) FINDRGBLOCK(S1SETREP_SIZE)
(*peg 27sep79*) else if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
end;
end;
REG_DATUM (STE, CODESTART, DTYPE, NXTRG);
REG_OPERAND (OPND1, NXTRG);
EMITXOP (MOVEOP, OPND1, OPND2);
end (*non-level register and short offset*)
else
begin
if not (((DTYPE in [TYPUA,TYPUM]) or (FINALIND>IND0))
and (NVPAS=1) and FITS_SHORT_INDEX(VPA1) ) then
ASSERTFAIL('VP_FP_FIN001');
if FPA.MEMADR.LVL > 0 then
XTNDED_REGDISP_OPERAND (OPND2,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
else if DTYPE <> TYPUM then
ADDR_OPERAND (OPND2, FPA.MEMADR.DSPLMT)
else
begin
XTNDED_REGDISP_OPERAND (OPND2,
S1RPC, FPA.MEMADR.DSPLMT);
OPND2.FIXUP := STRINGFIX;
DTYPE := TYPUA;
end;
INSERT_SHORT_VPA (OPND2, VPA1);
FREEDATUMREGS (STE);
if FINALIND = IND0 then
begin
MOVEOP := XMOV_A; FINDRG
end
else
begin
MOVEOP := MOV_X_X[DTYPE];
(*pn 27sep79...*) if DTYPE = TYPUS then
FINDRGBLOCK(S1SETREP_SIZE)
(*...pn 27sep79*) else if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
if FINALIND = IND2 then OPND2.XW.I := 1;
end;
REG_DATUM (STE, CODESTART, DTYPE, NXTRG);
REG_OPERAND (OPND1, NXTRG);
EMITXOP (MOVEOP, OPND1, OPND2);
end (*with STK[STE]*)
end (*VPA_FPA_FINALIND*);
procedure SHORT_AND_REG (var VSHORT, VREG : VPAREC);
(*Combine the two VPAs and the FPA displacement into
a simple register by address arithmetic. Allow
for the possibility that this may completely sum
the parts; in that case include FINALIND in the
operand to completely simplify the datum. Note
that the FPA level may be implicit due to DTYPE=TYPUM.*)
var OPND1, OPND2 : OPERAND;
MOVEOP : S1OPCODE;
begin
with STK[STE] do
begin
if not ((DTYPE in [TYPUA,TYPUM]) or (FINALIND > IND0) ) then
ASSERTFAIL('SHORT®001');
XTNDED_REGDISP_OPERAND (OPND2,
VREG.VPA.RGADR, FPA.MEMADR.DSPLMT);
INSERT_SHORT_VPA (OPND2, VSHORT);
FPA.MEMADR.DSPLMT := 0;
FREEVPAREG (VPA1);
FREEVPAREG (VPA2);
VPA1 := ZEROVPA; VPA2 := ZEROVPA;
NVPAS := 1;
if (FINALIND=IND0) or
(FPA.MEMADR.LVL>0) or (DTYPE=TYPUM) then
begin
MOVEOP := XMOV_A; FINDRG
end
else
begin
MOVEOP := MOV_X_X [DTYPE];
(*pn 27sep79...*) if DTYPE = TYPUS then
FINDRGBLOCK(S1SETREP_SIZE)
(*...pn 27sep79*) else if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
if FINALIND = IND2 then OPND2.XW.I := 1;
FINALIND := IND0;
end;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
REG_OPERAND (OPND1, NXTRG);
EMITXOP (MOVEOP, OPND1, OPND2);
end (*with STK[STE]*)
end (*SHORT_AND_REG*);
procedure CALCULATE_FPA;
(*Combine the FPA level and displacement by address
arithmetic. The level may be implicitly PC-relative
by virtue of the datum's being TYPUM. Assume no
VPAs and FINALIND = IND0.*)
var OPND1, OPND2 : OPERAND;
begin
with STK[STE] do
begin
if not ((DTYPE in [TYPUA,TYPUM]) and
(NVPAS=0) and (FINALIND=IND0) ) then
ASSERTFAIL('CALC_FPA 001');
FINDRG;
REG_OPERAND (OPND1, NXTRG);
if DTYPE <> TYPUM then
REGDISP_OPERAND (OPND2,
LVL_TO_S1REG [FPA.MEMADR.LVL],
FPA.MEMADR.DSPLMT)
else
begin
XTNDED_REGDISP_OPERAND
(OPND2, S1RPC, FPA.MEMADR.DSPLMT);
OPND2.FIXUP := STRINGFIX;
DTYPE := TYPUA;
end;
FPA := ZEROFPA;
NVPAS := 1;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
EMITXOP (XMOV_A, OPND1, OPND2);
end (*with STK[STE]*)
end (*CALCULATE_FPA*);
procedure DEREF_AND_SHIFT (var V : VPAREC);
(*Build an operand from the VPA neglecting shift and
emit a SHIFT instruction to reduce the VPA to
a simple register.*)
var OPND1, OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
if not ((FINALIND>IND0) or (DTYPE in [TYPUA,TYPUM,TYPUJ,TYPUL]) ) then
ASSERTFAIL('DEREFSHFT001');
VPA_OPERAND_NOSHIFT (OPND1, V);
IMM_OPERAND (OPND2, V.VSHIFT);
ALLOC_AND_EMIT_TOP (DEST, XSHFA_LF_S, OPND1, OPND2,
false, false, false, STE);
FREVPARGUNLESS (V, DEST);
V := ZEROVPA;
V.VPA.WHICH := RGS;
V.VPA.RGADR := DEST;
end (*DEREF_AND_SHIFT*);
procedure SHIFT_VPA1 (var OPND : OPERAND);
(*OPND describes VPA1. Emit a SHIFT instruction to
reduce VPA1 to a simple register.*)
var OPND2 : OPERAND;
DEST : S1REGISTER;
begin
with STK[STE] do
begin
if not ((FINALIND>IND0) or (DTYPE in [TYPUA,TYPUM,TYPUJ,TYPUL]) ) then
ASSERTFAIL('SHIFTVPA 001');
IMM_OPERAND (OPND2, VPA1.VSHIFT);
ALLOC_AND_EMIT_TOP (DEST, XSHFA_LF_S, OPND, OPND2,
false, false, false, STE);
FREVPARGUNLESS (VPA1, DEST);
VPA1 := ZEROVPA;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := DEST;
end (*with STK[STE]*)
end (*SHIFT_VPA1*);
procedure DEREF (var V : VPAREC; var OPND : OPERAND);
(*OPND describes the VPA, posibly with additional
indirection. Generate a MOV using this operand,
which will reduce the VPA to a simple register without
completely simplifying the datum. (Both these
conditions are assured by the caller.)*)
var OPNDR : OPERAND;
begin
FREEVPAREG (V);
FINDRG;
REG_OPERAND (OPNDR, NXTRG);
EMITXOP (XMOV_S_S, OPNDR, OPND);
V := ZEROVPA;
V.VPA.WHICH := RGS;
V.VPA.RGADR := NXTRG
end (*DEREF*);
procedure DEREF_TO_END (var V : VPAREC;
var OPND : OPERAND; DTYPE : OPNDTYPE);
(*OPND describes the VPA, possibly with some extra
indirection. Generate a MOV using this operand to
reduce the VPA to a simple register. This operation
is guaranteed to completely simplify the datum, which
is of type DTYPE.*)
var OPNDR : OPERAND;
begin
FREEVPAREG (V);
(*pn 27sep79...*) if STK[STE].DTYPE = TYPUS then
FINDRGBLOCK(S1SETREP_SIZE)
(*...pn 27sep79*) else if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
REG_OPERAND (OPNDR, NXTRG);
EMITXOP (MOV_X_X[DTYPE], OPNDR, OPND);
V := ZEROVPA;
V.VPA.WHICH := RGS;
V.VPA.RGADR := NXTRG;
end (*DEREF_TO_END*);
begin (*SIMPLIFY*)
with STK[STE] do
begin
if FPA.WHICH = RGS then
ERROR (WINDEXING_IN_PARMS);
if (FINALIND=IND0) and not(DTYPE in [TYPUA,TYPUM]) then
begin (*no address arithmetic allowed*)
if FPA.MEMADR.LVL <> 0 then ASSERTFAIL('SIMPLIFY 001');
case NVPAS of
(*NVPAS = *) 0:
if not ( false) then ASSERTFAIL('SIMPLIFY 002');
(*NVPAS = *) 1:
begin
VPA_OPERAND_NOSHIFT (OPND, VPA1);
if VPA1.VSHIFT > 0 then
SHIFT_VPA1 (OPND)
else if FPA.MEMADR.DSPLMT <> 0 then
FPA_DSPLMT_PLUS_VPA1 (OPND)
else
begin
if not ( not IS_SIMPLE(VPA1) ) then
ASSERTFAIL('SIMPLIFY 003');
DEREF_TO_END (VPA1, OPND, DTYPE);
end
end (*NVPAS = 1*);
(*NVPAS = *) 2:
if VPA1.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA1)
else if VPA2.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA2)
else
ADD_VPAS;
end (*case NVPAS*);
end (*no address arithmetic allowed*)
else
begin (*address arithmetic allowed. In fact, to
prevent an address from looking like an
indirect address pointer, address arithmetic
is required if a non-address operation
would completely simplify the datum.*)
case NVPAS of
(*NVPAS = *) 0:
begin
if not ((DTYPE = TYPUM) or
(FPA.MEMADR.LVL>0) and (FPA.MEMADR.DSPLMT<>0) ) then
ASSERTFAIL('SIMPLIFY 004');
CALCULATE_FPA
end (*NVPAS = 0*);
(*NVPAS = *) 1:
begin
if not (not ((DTYPE<>TYPUM) and (FPA=ZEROFPA) and
IS_SIMPLE(VPA1) ) ) then
ASSERTFAIL('SIMPLIFY 005');
if FITS_SHORT_INDEX (VPA1) then
VPA_FPA_FINALIND
else
begin (*requires extended address*)
VPA_OPERAND_NOSHIFT (OPND, VPA1);
if VPA1.VSHIFT > 0 then
begin
if (FPA=ZEROFPA) and (DTYPE<>TYPUM) then
ERROR (WINDEX_WITHOUT_BASE);
SHIFT_VPA1 (OPND)
end
else if (FPA.MEMADR.LVL>0)
and (FPA.MEMADR.DSPLMT<>0) then
FPA_LVL_PLUS_VPA1 (OPND)
else if (DTYPE=TYPUM) or (FPA<>ZEROFPA) then
DEREF (VPA1, OPND)
else
begin (*dereference some or all the way*)
if not (OPND.X = 1) then ASSERTFAIL('SIMPLIFY 006');
if (FINALIND>IND0) and (OPND.XW.I=0) then
begin
OPND.XW.I := 1;
FINALIND := pred(FINALIND);
end;
if FINALIND = IND0 then
DEREF_TO_END (VPA1, OPND, DTYPE)
else
begin
DEREF (VPA1, OPND);
VPA1.VPAIND := IND2;
FINALIND := pred(FINALIND)
end;
end (*dereference*)
end (*requires extended address*)
end (*NVPAS = 1*);
(*NVPAS = *) 2:
if IS_SIMPLE(VPA1) and
FITS_SHORT_INDEX(VPA2) then
SHORT_AND_REG (VPA2, VPA1)
else if IS_SIMPLE(VPA2) and
FITS_SHORT_INDEX(VPA1) then
SHORT_AND_REG (VPA1, VPA2)
else if (DTYPE<>TYPUM) and (FPA=ZEROFPA) then
begin
(*be careful not to finish simplification
with integer arithmetic.*)
if VPA1.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA1)
else if not IS_SIMPLE(VPA1) then
begin
VPA_OPERAND_NOSHIFT (OPND, VPA1);
DEREF (VPA1, OPND)
end
else if VPA2.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA2)
else
begin
VPA_OPERAND_NOSHIFT (OPND, VPA2);
DEREF (VPA2, OPND)
end
end (*be careful...*)
else if VPA1.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA1)
else if VPA2.VSHIFT > 0 then
DEREF_AND_SHIFT (VPA2)
else
ADD_VPAS;
end (*case NVPAS*);
end (*address arithmetic allowed*)
end (*with STK[STE]*);
if TR_SIMP then
begin
WRITELN (OUTPUT, ' Instruction(s) emitted:');
if OLDINSTREC = nil then OLDINSTREC := MAINCODE.FIRST;
while OLDINSTREC <> nil do
begin
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, OLDINSTREC);
OLDINSTREC := OLDINSTREC↑.NEXTPTR; (*DATASTRCH*)
end;
OLDINSTREC := NEWINSTREC;
WRITELN (OUTPUT, ' Datum simplified');
PRINTDATUM (STE)
end;
end (*SIMPLIFY*);
(** DISASSEMBLE_CLASS: DISASSEMBLE PRINTLOC PRINTIWORD PRINTXW1 PRINTXW2 PRINTOPERAND PRINTREG PRINT_SIGNED_OCTAL PRINTSHORTOP **)
(**)
procedure DISASSEMBLE(*(var CURPC : integer; IPTR : AN_INSTREC)*);(*DATASTRCH*)
(*This procedure disassembles and prints a single S1 instruction
starting at the word pointed to by IPTR, using CURPC as the
location of that instruction, and updates CURPC to indicate the
location of the next instruction.*)
var CURS1OPC : S1OPCODE;
XPTR1, XPTR2 : AN_OPERANDXWORD; (*DATASTRCH*)
T : TWOBITS;
SLOC : CHAR10;
I, J : integer; (*LCW*)
ANS : CHAR12;
(* Output format :
.........1.........2.........3.........4.........5.........6.........7
locationxx : instrwordxxx opcodemnemonicx <operands>
xopnd1wordxx (if any)
xopnd2wordxx (if any)
*)
procedure PRINTPTRADDR (IPTR : AN_INSTREC); (*DATASTRCH*)(*15JAN79 PTZ*)
var IPI : INSTREC_PTRINT;
begin
IPI.PTR := IPTR;
WRITE(OUTPUT,'(',IPI.INT:8,')')
end (*PRINTPTRADDR*);
procedure PRINTLOC;
var SLOC : CHAR10;
begin
if not JUMPS_CONCRETIZED then (*15JAN79 PTZ*)
PRINTPTRADDR(IPTR); (*15JAN79 PTZ*)
CVOS_10(SLOC,CURPC);
WRITE(OUTPUT,SLOC,' : ')
end (*PRINTLOC*);
procedure PRINTIWORD;
var SWORD : CHAR12;
begin
CVOS_S1WORD_12(SWORD,S1INSTBUF[S1INST]);
WRITE(OUTPUT,SWORD,' ')
end (*PRINTIWORD*);
procedure PRINTXW1;
var SWORD : CHAR12;
begin
(* if no xword1 test made before call ALS*)(*DATASTRCH*)
CVOS_S1WORD_12(SWORD,S1INSTBUF[S1OPND1XWD]); (*DATASTRCH*)
if not JUMPS_CONCRETIZED then (*15JAN79 PTZ*)
WRITE(OUTPUT,' '); (*space taken by ptr addr - PTZ*)
WRITELN(OUTPUT,' ',SWORD)
end (*PRINTXW1*);
procedure PRINTXW2;
var SWORD : CHAR12;
begin
(* if no xword2 test made before call ALS*)(*DATASTRCH*)
CVOS_S1WORD_12(SWORD,S1INSTBUF[S1OPND2XWD]);
if not JUMPS_CONCRETIZED then (*15JAN79 PTZ*)
WRITE(OUTPUT,' '); (*space taken by ptr addr - PTZ*)
WRITELN(OUTPUT,' ',SWORD)
end (*PRINTXW2*);
procedure PRINTOPERAND(var OPND : INSTOPND); (*DATASTRCH*)
(*Disassemble and print one S1 operand contained in OPND. Extended
part (if any) is in the OPND.XWD↑ *)
var I, J, K, KSIGN, KWID : integer;
OPNDX : BIT;
OPNDREG : S1REGISTER;
OPNDF : MINSHORTOFFSET..MAXSHORTOFFSET;
XWORD : S1WORD;
SWORD : CHAR12;
procedure PRINTREG(R : S1REGISTER);
var
ANS : CHAR2;
I, J : 1..2;
begin
J := 1;
if R = S1RTA then WRITE(OUTPUT,'%RTA')
else if R = S1RTB then WRITE(OUTPUT,'%RTB')
else
begin
WRITE (OUTPUT,'%');
ANS[2] := chr(ord('0') + (R mod 8));
R := R div 8;
if R > 0 then ANS[1] := chr(ord('0') + R)
else J := J + 1;
for I := J to 2 do WRITE(OUTPUT,ANS[I]);
end
end (*PRINTREG*);
procedure PRINT_SIGNED_OCTAL(K : integer); (*30dec78 ALS*)
begin
IF K < 0 then
begin
K := - K;
WRITE (OUTPUT,'-');
end;
CVOS_12(ANS,K);
J := 1;
while ANS[J] = ' ' do J := J + 1;
for I := J to 12 do WRITE(OUTPUT,ANS[I]);
end (*PRINT_SIGNED_OCTAL*);
procedure PRINTSHORTOP;
begin
if OPNDREG = 0 then PRINTREG(OPNDF)
else if OPNDREG = 1 then
begin (*short constant*)
WRITE(OUTPUT,'#');
PRINT_SIGNED_OCTAL(OPNDF); (*31DEC78 ALS*)
end (*short constant*)
else if OPNDREG = 2 then
begin
if not (false) then
ASSERTFAIL('PRINTSHOR001')
end
else
begin (*short indexed*)
if not ((3 <= OPNDREG) and (OPNDREG <= LASTS1REG)) then
ASSERTFAIL('PRINTSHOR002');
PRINT_SIGNED_OCTAL(OPNDF); (*31DEC78 ALS*)
WRITE(OUTPUT,'*4'); (*FASM requires this 3JAN79 ALS*)
WRITE(OUTPUT,'('); (*31dec78 ALS*)
PRINTREG(OPNDREG);
WRITE(OUTPUT,')');
end (*short indexed*)
end (*PRINTSHORTOP*);
begin (*PRINTOPERAND*)
with OPND do
begin
if XWD <> nil then OPNDX := 1
else OPNDX := 0;
OPNDREG := REG;
OPNDF := F
end(*with OPND*);
if OPNDX = 1 then
begin (*extended operand*)
if (OPNDREG = 1) and (OPNDF <> 0) then
begin (*long constant*)
if not ((OPNDF>=1) and (OPNDF<=3)) then ASSERTFAIL('PRINTOPER001');
(*DATASTRCH*)
XWORD := OPND.XWD↑.VAL; (*DATASTRCH*)
KSIGN := GETSIGNEDFIELD(XWORD,0,6);
WRITE(OUTPUT,'#',CHR(124)); (*LCW*)
if ((KSIGN=0) or (KSIGN=-1)) and (OPNDF = 1) then
begin (*print signed octal*) (*30dec78 ALS*)
K := GETSIGNEDFIELD(XWORD,WORDBITS-(BITS_ON_COMP_MACH-1),
BITS_ON_COMP_MACH - 1);
if not (((KSIGN=0) and (K>=0))
or ((KSIGN=-1) and (K<0))) then
ASSERTFAIL('PRINTOPER002'); (*DATASTRCH*)
PRINT_SIGNED_OCTAL(K); (*31DEC78 ALS*)
end (*print signed octal*)
else
begin (*print in octal*)
CVOS_S1WORD_12(SWORD,XWORD);
J := 1;
while SWORD[J] = ' ' do J := J + 1;
for I := J to 12 do WRITE(OUTPUT,SWORD[I]);
if OPNDF <> 1 then
begin
WRITE(OUTPUT,'F',OPNDF:1); (*???*)
end;
end; (*print in octal*) (*LCW*)
WRITE(OUTPUT,CHR(124)); (*LCW*)
end (*long constant*)
else
begin (*extended address*)
WRITE(OUTPUT,CHR(124)); (*LCW*)
with OPND.XWD↑ do (*DATASTRCH*)
begin(*with OPND.XWD↑*)
if I = 1 then (*DATASTRCH*)
begin (*indirect bit*)
WRITE(OUTPUT,'@'); (*LCW*)
end (*indirect bit*);
if V = 1 then (*DATASTRCH*)
begin (*variable base*)
K := DISP; (*DATASTRCH*)
(* write in octal always*) (*29dec78 ALS*)
PRINT_SIGNED_OCTAL(K);
WRITE(OUTPUT,'(');
PRINTREG(REG); (*DATASTRCH*)
WRITE(OUTPUT,')');
end (*variable base*)
else
begin (*fixed base*)
K := ADDR; (*DATASTRCH*) (*ALS*)
if (IPTR↑.OPCODE = XJSR)and(K <> 0) then
K := K -(MAXS1ADDR +1); (*DATASTRCH*)
(*A kludge to match the concretizer in handling negative ADDR value*)
PRINT_SIGNED_OCTAL(K); (*30DEC78 ALS*)
end (*fixed base*);
WRITE(OUTPUT,CHR(124)); (*LCW*)
if (OPNDREG=1) and (OPNDF=0) then
(*short-zero mode: no index to print*)
else
begin (*print index*)
WRITE(OUTPUT,'('); (*LCW*)
PRINTSHORTOP;
WRITE(OUTPUT,')'); (*LCW*)
K := S; (*DATASTRCH*)
if K <> 0 then
begin (*print shift*)
WRITE(OUTPUT,'↑'); (*LCW*)
PRINT_SIGNED_OCTAL(K); (*31DEC78 ALS*)
end (*print shift*);
end (*print index*)
end(*with OPND.XWD↑*)
end(*extended address*)
end (*extended operand*)
else
begin (*short operand*)
PRINTSHORTOP
end (*short operand*)
end (*PRINTOPERAND*);
begin (*DISASSEMBLE*)
CURS1OPC := IPTR↑.OPCODE; (*DATASTRCH*)
XPTR1 := IPTR↑.INSTOPND1.XWD; (*DATASTRCH*)
XPTR2 := IPTR↑.INSTOPND2.XWD; (*DATASTRCH*)
case OPFORMAT[CURS1OPC] of
VFAKEOP:
if not JUMPS_CONCRETIZED then (*15JAN79 PTZ...*)
begin
FORMFAKEINST(IPTR); (*DATASTRCH*)
PRINTLOC;
PRINTIWORD;
WRITE(OUTPUT,S1MNEM[CURS1OPC],' '); (*PRINTOPCODE*)
CVOS_10(SLOC,IPTR↑.FAKEOPND); (*DATASTRCH*)
J := 1;
while SLOC[J] = ' ' do J := J+1;
for I := J to 10 do WRITE(OUTPUT,SLOC[I]);
WRITELN(OUTPUT)
end
(*else ignore it*); (*...15JAN79 PTZ*)
VTOP, VXOP, VSOP:
begin
if OPFORMAT[CURS1OPC] = VTOP then
FORMTOP(IPTR) (*DATASTRCH*)
else if OPFORMAT[CURS1OPC] = VXOP then
FORMXOP(IPTR) (*DATASTRCH*)
else if OPFORMAT[CURS1OPC] = VSOP then
FORMSOP(IPTR); (*DATASTRCH*)
PRINTLOC;
PRINTIWORD;
WRITE(OUTPUT,S1MNEM[CURS1OPC],' '); (*PRINTOPCODE*) (*ALS*)
if OPFORMAT[CURS1OPC] = VTOP then
begin (*VTOP*)
T := IPTR↑.T; (*DATASTRCH*)
if T = 1 then
begin (* OP1 = RTA, OP2 *)
PRINTOPERAND(IPTR↑.INSTOPND1); (*DATASTRCH*)
WRITE(OUTPUT,',%RTA,'); (*LCW*)
PRINTOPERAND(IPTR↑.INSTOPND2); (*DATASTRCH*)
end (* OP1 = RTA, OP2 *)
else
begin
if T = 2 then WRITE(OUTPUT,'%RTA,') (*LCW*)
else if T = 3 then WRITE(OUTPUT,'%RTB,') (*LCW*)
(*else T = 0*);
PRINTOPERAND(IPTR↑.INSTOPND1); (*DATASTRCH*)
WRITE(OUTPUT,',');
PRINTOPERAND(IPTR↑.INSTOPND2); (*DATASTRCH*)
end
end (*VTOP*)
else
begin (*VXOP, VSOP*)
PRINTOPERAND(IPTR↑.INSTOPND1); (*DATASTRCH*)
WRITE(OUTPUT,',');
PRINTOPERAND(IPTR↑.INSTOPND2); (*DATASTRCH*)
if OPFORMAT[CURS1OPC] = VSOP then
begin (*VSOP*)
WRITE(OUTPUT,','); (*LCW*)
if JUMPS_CONCRETIZED then (*15JAN79 PTZ*)
begin
CVOS_10(SLOC,CURPC + WORDUNITS*IPTR↑.SKP);(*DATASTRCH*)
J := 1; (*LCW*)
while SLOC[J] = ' ' do J := J+1; (*LCW*)
for I := J to 10 do WRITE(OUTPUT,SLOC[I]); (*LCW*)
end
else
PRINTPTRADDR(IPTR↑.DESTPTR);(*15JAN79 PTZ*)(*DATASTRCH*)
end (*VSOP*)
end (*VXOP, VSOP*);
WRITELN(OUTPUT);
if XPTR2 <> nil then PRINTXW2; (*3JAN79 ALS*)
if XPTR1 <> nil then PRINTXW1; (*3JAN79 ALS*)
end (*VTOP, VXOP, VSOP*);
VJOP:
begin
FORMJOP(IPTR); (*DATASTRCH*)
PRINTLOC;
PRINTIWORD;
WRITE(OUTPUT,S1MNEM[CURS1OPC],' '); (*PRINTOPCODE*) (*ALS*)
PRINTOPERAND(IPTR↑.INSTOPND1); (*DATASTRCH*)
WRITE(OUTPUT,','); (*LCW*)
if JUMPS_CONCRETIZED then
begin
if IPTR↑.PR = 1 then (*DATASTRCH*)
begin (*PC relative*)
CVOS_10(SLOC,CURPC + WORDUNITS*IPTR↑.J); (*DATASTRCH*)
J := 1; (*LCW*)
while SLOC[J] = ' ' do J := J+1; (*LCW*)
for I := J to 10 do WRITE(OUTPUT,SLOC[I]); (*LCW*)
end (*PC relative*)
else
begin (*print OPND2*)
PRINTOPERAND(IPTR↑.INSTOPND2) (*DATASTRCH*)
end (*print OPND2*)
end
else
begin
PRINTOPERAND(IPTR↑.INSTOPND2); (*28AUG79 PTZ*)
PRINTPTRADDR(IPTR↑.DESTPTR);(*15JAN79 PTZ*)(*DATASTRCH*)
end;
WRITELN(OUTPUT);
if XPTR2 <> nil then PRINTXW2; (*3JAN79 ALS*)
if XPTR1 <> nil then PRINTXW1; (*3JAN79 ALS*)
end (*VJOP*)
end (*case*);
CURPC := CURPC + IPTR↑.IWDS * WORDUNITS;
end (*DISASSEMBLE*);
(** OBJECT_MODULE_SEGMENT_CLASS: GEN_PSWITCH CODE_CONCRETIZER CONCPAS1 INSERTS1LOC JMPX_TO_JMPA_OPT **)
(**)
procedure GEN_PSWITCH;
begin
end;
procedure CODE_CONCRETIZER;
(*Concretize the MAINCODE code in three passes. On pass 1, insert
fake S1LOC instructions at each jump or skip destination. On
pass 2, compute a final PC value as code is passed, filling the
current PC value into each S1LOC instruction. Also, fix up all
PC relative extended operands by subtracting the PC value from
their displacements. On pass 3, fix up all jump and skip
instructions by inserting final PC relative references.*)
var
IPTR : AN_INSTREC;
NXTPC, TPC, PASS2_MAXPC : 0..MAXS1LOC;
PROC_WDS_REMOVED : integer; (*28APR79 PTZ*)
procedure CONCPAS1; (*PBK*)
(* first pass over the code inserts S1LOC fake instructions
at the destination of each skip or jump.
peephole optimization of jumps to jumps is done during
this pass. *)
procedure INSERTS1LOC (JMPORSKPPTR : AN_INSTREC); (*PBK*)
(*28APR79 PTZ*) (*DATASTRCH*)
(* This inserts an S1LOC fake instruction before the INSTREC
that is the destination of the jump or skip at JMPORSKPPTR.
If there was already an S1LOC there, change
ptrs so that each S1LOC marking this as a jmp or skp destination
will be pointed to by exactly one jmp or skp *) (*28APR79 PTZ*)
var
BEFORE, TPTR : AN_INSTREC;
begin
BEFORE := JMPORSKPPTR↑.DESTPTR;
if BEFORE <> nil then
(* if BEFORE↑.OPCODE <> XS1LOC then PBK*)
begin
MAKE_NEWINSTREC(TPTR);
with TPTR↑ do
begin
OPCODE := XS1LOC;
OPFMT := VFAKEOP;
FAKEOPND := S1LOCUNDEF;
IWDS := 0;
NEXTPTR := BEFORE;
PREVPTR := BEFORE↑.PREVPTR;
BEFORE↑.PREVPTR := TPTR;
if PREVPTR = nil then
MAINCODE.FIRST := TPTR
else
PREVPTR↑.NEXTPTR := TPTR;
end;
JMPORSKPPTR↑.DESTPTR := TPTR;
MAINCODE.NWORDS := MAINCODE.NWORDS + 1;
end (* if BEFORE <> nil then *);
end (* procedure INSERTS1LOC *);
procedure JMPX_TO_JMPA_OPT ( INSTLOC : AN_INSTREC ); (*PBK*) (*DATASTRCH*)
(* This procedure takes the jump instruction at INSTLOC
and follows the chain (if any) of its destination
through any JMPAs to make the destination the final
destination of the chain of JMPAs (if any).
This saves just a little bit of time, but it makes
the code more esthetically pleasing [huh?] *)
var
JMP_TO_JMPA : boolean;
JUMPDEST, DESTINST : AN_INSTREC;
begin
if INSTLOC↑.INSTOPND2.XWD = nil then
begin
JUMPDEST := INSTLOC↑.DESTPTR;
repeat (* until not JMP_TO_JMPA *)
JMP_TO_JMPA := false;
if JUMPDEST <> nil then
begin
DESTINST := AFTER_FAKEOPS(JUMPDEST);
if DESTINST <> nil then
begin
if DESTINST↑.OPCODE = XJMPA then
begin
JUMPDEST := DESTINST↑.DESTPTR;
JMP_TO_JMPA := true;
J_TO_J_CNT := J_TO_J_CNT + 1;
end (* if DESTINST↑.OPCODE = XJMPA then *)
end (* if DESTINST <> nil then *)
end (* if JUMPDEST <> nil then *)
until not JMP_TO_JMPA;
(* fix jump or skip destination of start of jump chain *)
INSTLOC↑.DESTPTR := JUMPDEST;
end;
(* else
this JMPX has an extended destination word and hence is
too complicated to chain - specifically it may be an
indexed jump into a jump table (in this case the jumpdest
ptr points to the first jump in the table - DON'T chain
this since it won't in general actually execute through
the first jump) *)
end (* JMPX_TO_JMPA_OPT *);
begin (* CONCPAS1 *) (*DATASTRCH*)
if TR_PEEPHOLE then (*14JAN79 PTZ*)
begin
WRITELN(OUTPUT,'----------------------------- ;START OF ',
CURPROCXN.NAM,' ',CURPROC);
WRITELN(OUTPUT,'before S1LOC insertion pass :');
WRITELN(OUTPUT,'-----------------------------');
PRINTMAINCODE (*28APR79 PTZ*)
end;
IPTR := MAINCODE.FIRST;
while IPTR <> nil do
begin
if IPTR↑.OPFMT in [VJOP,VSOP] then
begin
if (IPTR↑.OPFMT = VJOP) and not NO_JMPX_TO_JMPA_FLG then
(* attempt to optimize jumps to JMPAs.
don't try to do skips to JMPAs, since
that would almost certainly make the skip
not reach, and we can't fix that up now. *)
JMPX_TO_JMPA_OPT(IPTR);
INSERTS1LOC(IPTR); (*28APR79 PTZ*)
end (* if IPTR↑.OPFMT in [VJOP,VSOP] then *);
IPTR := IPTR↑.NEXTPTR
end (*while IPTR <> nil do*);
if MAINCODE.LAST <> nil then
while MAINCODE.LAST↑.NEXTPTR <> nil do
MAINCODE.LAST := MAINCODE.LAST↑.NEXTPTR;
end (*CONCPAS1*);
(** OBJECT_MODULE_SEGMENT_CLASS: PEEPHOLE_OPTIMIZER SKIP_JMPA_OPT INC_SKP_OPT **)
(**)
procedure PEEPHOLE_OPTIMIZER (*(var CHANGES : boolean)*) ; (*PTZ*)
(*28APR79 PTZ*) (*DATASTRCH*)
var PREVIPTR : AN_INSTREC;
OLDNWORDS : integer;
CHANGES : boolean;
procedure SKIP_JMPA_OPT (var SKIPPTR : AN_INSTREC; SKIPPC : integer);
(*DATASTRCH*)
var JMPAPTR, L2PTR, TPTR, L1PTR : AN_INSTREC;
L2PC : 0..MAXS1LOC;
JMPOFF : integer;
STILL_LOOKING : boolean;
begin
JMPAPTR := AFTER_NONS1LOC_FAKEOPS(SKIPPTR↑.NEXTPTR);
if JMPAPTR <> nil then
begin
if (JMPAPTR↑.OPCODE = XJMPA)
and (JMPAPTR↑.PR <> 1) then
begin (*not in jump table*)
L1PTR := SKIPPTR↑.DESTPTR;
L2PTR := JMPAPTR↑.DESTPTR;
if not ((L1PTR↑.OPCODE = XS1LOC)
and (L2PTR↑.OPCODE = XS1LOC)) then
ASSERTFAIL('SKIP_JMPA001');
TPTR := JMPAPTR↑.NEXTPTR;
STILL_LOOKING := true;
while (TPTR <> nil) and STILL_LOOKING do
begin
STILL_LOOKING :=
(TPTR↑.OPFMT = VFAKEOP) and
(TPTR <> L1PTR);
if STILL_LOOKING then
TPTR := TPTR↑.NEXTPTR
end;
if TPTR = L1PTR then
begin (*the SKP skips around the JMPA*)
L2PC := L2PTR↑.FAKEOPND;
if L2PC <> S1LOCUNDEF then
begin (*backward skip or ≥ 2nd pass*)
JMPOFF := (L2PC - SKIPPC) div WORDUNITS;
if JMPOFF > 0 then
(*28AUG79 PTZ*) JMPOFF := JMPOFF - JMPAPTR↑.IWDS
- (OLDNWORDS - MAINCODE.NWORDS)
end
else
begin (*forward skip: 1st pass only*)
(*28AUG79 PTZ*) JMPOFF := SKIPPTR↑.IWDS;
TPTR := JMPAPTR↑.NEXTPTR;
while (JMPOFF <= MAXSKPOFFSET) and (TPTR <> L2PTR)
and (TPTR <> nil) do
begin
(*1OCT79 PTZ*) JMPOFF := JMPOFF
(*in case TPTR↑.OPFMT = VJOP*) + INSTR_WORDS(TPTR,SKIPPC + JMPOFF*WORDUNITS);
TPTR := TPTR↑.NEXTPTR
end;
end;
if (MINSKPOFFSET <= JMPOFF)
and (JMPOFF <= MAXSKPOFFSET) then
begin
(* SKP.COND.X Y,Z,L1 *) JMPAS_REMOVED_FROM_SKIPS :=
(* JMPA L2 *) JMPAS_REMOVED_FROM_SKIPS + 1;
(*L1: S1LOC *) SKIPPTR↑.OPCODE := INVERSE_SKIP[SKIPPTR↑.OPCODE];
(* (MINSKPOFFSET<=L2-SKP *) SKIPPTR↑.DESTPTR := L2PTR;
(* <=MAXSKPOFFSET) *)
(* => *) DELETE_INSTR(JMPAPTR);
(* SKP.invCOND.X Y,Z,L2 *) DELETE_INSTR(L1PTR)
(* There is 1 S1LOC for each time a place is used as a
destination, so we can optimize across the boundary
when the last one goes away *)
end
end (*if TPTR = L1PTR then*)
end
end (*if JMPAPTR <> nil then*)
end (*SKIP_JMPA_OPT*);
procedure INC_SKP_OPT (var INCDECPTR : AN_INSTREC); (*28JUN79 PTZ*)
(*DATASTRCH*)
var SKPJMPAPTR : AN_INSTREC;
SKPJMPAOPC, INCDECOPC, ISKPOPC : S1OPCODE;
begin
SKPJMPAPTR := AFTER_NONS1LOC_FAKEOPS(INCDECPTR↑.NEXTPTR);
if SKPJMPAPTR <> nil then
begin
if INCDECPTR↑.OPCODE = XINC_S then
ISKPOPC := ISKPJMPA_OPCODE[SKPJMPAPTR↑.OPCODE]
else
begin
if not (INCDECPTR↑.OPCODE = XDEC_S) then
ASSERTFAIL('INC_SKP 001');
ISKPOPC := DSKPJMPA_OPCODE[SKPJMPAPTR↑.OPCODE]
end;
if (ISKPOPC <> XILLEGAL)
and (S1OPNDS_EQUAL(INCDECPTR,OPND1NUM,INCDECPTR,OPND2NUM))
then
begin
if SKPJMPAPTR↑.OPCODE = XJMPA then
begin
if SKPJMPAPTR↑.PR <> 1 then
begin (*not in jump table*)
(* INCorDEC.S Y,Y *) INC_SKP_COLLAPSE[1] := INC_SKP_COLLAPSE[1] + 1;
(* JMPA L *) SKPJMPAPTR↑.OPCODE := ISKPOPC;
(* => *)
(* IorDJMPA Y,L *) INSERT_OPND1(SKPJMPAPTR,INCDECPTR↑.INSTOPND1);
DELETE_INSTR(INCDECPTR);
INCDECPTR := SKPJMPAPTR
end
end (*XJMPA*)
else
begin (*VSOP*)
if not (SKPJMPAPTR↑.OPFMT = VSOP) then
ASSERTFAIL('INC_SKP 002');
if S1OPNDS_EQUAL(INCDECPTR,OPND1NUM,
SKPJMPAPTR,OPND1NUM) then
begin
(* INCorDEC.S Y,Y *) INC_SKP_COLLAPSE[2] := INC_SKP_COLLAPSE[2] + 1;
(* SKP.ACOND.S Y,Z,L *) SKPJMPAPTR↑.OPCODE := ISKPOPC;
(* => *) DELETE_INSTR(INCDECPTR);
(* IorDSKP.ACOND Y,Z,L*) INCDECPTR := SKPJMPAPTR
end
else if S1OPNDS_EQUAL(INCDECPTR,OPND1NUM,
SKPJMPAPTR,OPND2NUM) then
begin
(* INCorDEC.S Y,Y *) INC_SKP_COLLAPSE[3] := INC_SKP_COLLAPSE[3] + 1;
(* SKP.ACOND.S Z,Y,L *) SKPJMPAPTR↑.OPCODE := REVERSE_OP[ISKPOPC];
(* => *) SWAP_OPERANDS(SKPJMPAPTR);
(* IorDSKP.revACOND *) DELETE_INSTR(INCDECPTR);
(* Y,Z,L *) INCDECPTR := SKPJMPAPTR
end
end (*VSOP*)
end
end
end (*INC_SKP_OPT*);
(** OBJECT_MODULE_SEGMENT_CLASS: COLLAPSE_MOV_OPT **)
(**)
procedure COLLAPSE_MOV_OPT (var OPPTR : AN_INSTREC); (*DATASTRCH*)
var MOV_OPND1, MOV_OPND2, T : integer;
MOVOPC, OPCODE : S1OPCODE;
MOVPTR : AN_INSTREC;
MOV_PRECISION : S1PRECISION;
begin
MOVPTR := AFTER_NONS1LOC_FAKEOPS(OPPTR↑.NEXTPTR);
if MOVPTR <> nil then
begin
MOVOPC := MOVPTR↑.OPCODE;
MOV_PRECISION := S1ILLEGAL;
if MOVOPC = XMOV_S_S then MOV_PRECISION := S1S
else if MOVOPC = XMOV_D_D then MOV_PRECISION := S1D
else if MOVOPC = XMOV_Q_Q then MOV_PRECISION := S1Q
else if MOVOPC = XMOV_H_H then MOV_PRECISION := S1H;
MOV_OPND2 := S1OPND_TEMPLOC(MOVPTR↑.INSTOPND2);
if (MOV_OPND2 >= 0)
and (DEST_PRECISION[OPPTR↑.OPCODE] = MOV_PRECISION)
and PEEP_LOC_IS_FREE(MOVPTR↑.NEXTPTR,MOV_OPND2)
then
begin
(*We now know that the source of the MOV.X.X is
no longer going to be used, and that the instruction
preceding the MOV.X.X is a collapsible one.
Now look for certain patterns in the collapsible inst*)
if OPPTR↑.OPFMT = VXOP then
begin
if S1OPND_TEMPLOC(OPPTR↑.INSTOPND1) = MOV_OPND2 then
begin
(* XOP.X.W TREG,Y *) MOV_COLLAPSE[1] := MOV_COLLAPSE[1] + 1;
(* MOV.X.X Z,TREG *) INSERT_OPND1(OPPTR,MOVPTR↑.INSTOPND1);
(* => *) DELETE_INSTR(MOVPTR)
(* XOP.X.W Z,Y *) end
end (*XOP*)
else
begin (*TOP*)
if not (OPPTR↑.OPFMT = VTOP) then
ASSERTFAIL('COLLAPSE 001');
case OPPTR↑.T of
0: if S1OPND_TEMPLOC(OPPTR↑.INSTOPND1) = MOV_OPND2 then
begin
if S1OPNDS_EQUAL(OPPTR,OPND2NUM,
MOVPTR,OPND1NUM) then
begin
(* TOP.X TREG,Y *) MOV_COLLAPSE[2] := MOV_COLLAPSE[2] + 1;
(* MOV.X.X Y,TREG *) INVERT_OPCODE(OPPTR);
(* => *) SWAP_OPERANDS(OPPTR);
(* reverseTOP.X Y,TREG *) DELETE_INSTR(MOVPTR)
end
else if MOV_OPND2 = S1RTA then
begin
(* TOP.X RTA,Y *) MOV_COLLAPSE[3] := MOV_COLLAPSE[3] + 1;
(* MOV.X.X Z,RTA *) INSERT_OPND1(OPPTR,MOVPTR↑.INSTOPND1);
(* => *) OPPTR↑.T := 1;
(* TOP.X Z,RTA,Y *) DELETE_INSTR(MOVPTR)
end
else if S1OPND_TEMPLOC(OPPTR↑.INSTOPND2)
= S1RTA then
begin
(* TOP.X TREG,RTA *) MOV_COLLAPSE[4] := MOV_COLLAPSE[4] + 1;
(* MOV.X.X Z,TREG *) INVERT_OPCODE(OPPTR);
(* => *) SWAP_OPERANDS(OPPTR);
(* reverseTOP.X Z,RTA,TREG *) INSERT_OPND1(OPPTR,MOVPTR↑.INSTOPND1);
OPPTR↑.T := 1;
DELETE_INSTR(MOVPTR)
end
else if S1OPND_TEMPLOC(MOVPTR↑.INSTOPND1)
= S1RTA then
begin
(* TOP.X TREG,Z *) MOV_COLLAPSE[5] := MOV_COLLAPSE[5] + 1;
(* MOV.X.X RTA,TREG *) OPPTR↑.T := 2;
(* => *) DELETE_INSTR(MOVPTR)
(* TOP.X RTA,TREG,Z *) end
else if S1OPND_TEMPLOC(MOVPTR↑.INSTOPND1)
= S1RTB then
begin
(* TOP.X TREG,Z *) MOV_COLLAPSE[6] := MOV_COLLAPSE[6] + 1;
(* MOV.X.X RTB,TREG *) OPPTR↑.T := 3;
(* => *) DELETE_INSTR(MOVPTR)
(* TOP.X RTB,TREG,Z *) end
end;
1: if S1OPND_TEMPLOC(OPPTR↑.INSTOPND1) = MOV_OPND2 then
begin
if S1OPNDS_EQUAL(OPPTR,OPND2NUM,
MOVPTR,OPND1NUM) then
begin
(* TOP.X TREG,RTA,Y *) MOV_COLLAPSE[7] := MOV_COLLAPSE[7] + 1;
(* MOV.X.X Y,TREG *) INVERT_OPCODE(OPPTR);
(* => *) OPPTR↑.T := 0;
(* reverseTOP.X Y,RTA *) SWAP_OPERANDS(OPPTR); (*gives Y,TREG*)
OPPTR↑.INSTOPND2.F := S1RTA; (*gives Y,RTA*)
DELETE_INSTR(MOVPTR)
end
else
begin
(* TOP.X TREG,RTA,Y *) MOV_COLLAPSE[8] := MOV_COLLAPSE[8] + 1;
(* MOV.X.X Z,TREG *) INSERT_OPND1(OPPTR,MOVPTR↑.INSTOPND1);
(* => *) DELETE_INSTR(MOVPTR)
(* TOP.X Z,RTA,Y *) end
end;
2,3:
if ((OPPTR↑.T=2) and (MOV_OPND2=S1RTA))
or ((OPPTR↑.T=3) and (MOV_OPND2=S1RTB)) then
begin
if S1OPNDS_EQUAL(OPPTR,OPND1NUM,
MOVPTR,OPND1NUM) then
begin
(* TOP.X RTAorRTB,Y,Z *) MOV_COLLAPSE[9] := MOV_COLLAPSE[9] + 1;
(* MOV.X.X Y,RTAorRTB *) OPPTR↑.T := 0;
(* => *) DELETE_INSTR(MOVPTR)
(* TOP.X Y,Z *) end
else if S1OPNDS_EQUAL(OPPTR,OPND2NUM,
MOVPTR,OPND1NUM) then
begin
(* TOP.X RTAorRTB,Z,Y *) MOV_COLLAPSE[10] := MOV_COLLAPSE[10] + 1;
(* MOV.X.X Y,RTAorRTB *) INVERT_OPCODE(OPPTR);
(* => *) OPPTR↑.T := 0;
(* reverseTOP.X Y,Z *) SWAP_OPERANDS(OPPTR);
DELETE_INSTR(MOVPTR)
end
else if MOV_OPND2 = S1RTB then
begin
if S1OPND_TEMPLOC(OPPTR↑.INSTOPND2)
= S1RTA then
begin
(* TOP.X RTB,Y,RTA *) MOV_COLLAPSE[11] := MOV_COLLAPSE[11] + 1;
(* MOV.X.X Z,RTB *) INVERT_OPCODE(OPPTR);
(* => *) SWAP_OPERANDS(OPPTR);
(* reverseTOP.X Z,RTA,Y *) INSERT_OPND1(OPPTR,MOVPTR↑.INSTOPND1);
OPPTR↑.T := 1;
DELETE_INSTR(MOVPTR)
end
else if S1OPND_TEMPLOC(OPPTR↑.INSTOPND1)
= S1RTA then
begin
(* TOP.X RTB,RTA,Y *) MOV_COLLAPSE[12] := MOV_COLLAPSE[12] + 1;
(* MOV.X.X Z,RTB *) INSERT_OPND1(OPPTR,MOVPTR↑.INSTOPND1);
(* => *) OPPTR↑.T := 1;
(* TOP.X Z,RTA,Y *) DELETE_INSTR(MOVPTR)
end
else if S1OPND_TEMPLOC(MOVPTR↑.INSTOPND1)
= S1RTA then
begin
(* TOP.X RTB,Y,Z *) MOV_COLLAPSE[13] := MOV_COLLAPSE[13] + 1;
(* MOV.X.X RTA,RTB *) OPPTR↑.T := 2;
(* => *) DELETE_INSTR(MOVPTR)
(* TOP.X RTA,Y,Z *) end
end
else if MOV_OPND2 = S1RTA then
begin
if S1OPND_TEMPLOC(MOVPTR↑.INSTOPND1)
= S1RTB then
begin
(* TOP.X RTA,Y,Z *) MOV_COLLAPSE[14] := MOV_COLLAPSE[14] + 1;
(* MOV.X.X RTB,RTA *) OPPTR↑.T := 3;
(* => *) DELETE_INSTR(MOVPTR)
(* TOP.X RTB,Y,Z *) end
end
end
end (*case*)
end (*TOP*)
end
end (*MOVPTR <> nil*)
end (*COLLAPSE_MOV_OPT*);
(** OBJECT_MODULE_SEGMENT_CLASS: PEEPHOLE_OPTIMIZER **)
(**)
begin (*PEEPHOLE_OPTIMIZER*) (*DATASTRCH*)
(* The first pass of the peephole optimizer removes or simplifies
any instructions that it can *)
if TR_PEEPHOLE then (*14JAN79 PTZ*)
begin
WRITELN(OUTPUT);
WRITELN(OUTPUT,'-------------------------');
WRITELN(OUTPUT,'before peephole pass 1 :');
WRITELN(OUTPUT,'-------------------------');
PRINTMAINCODE (*28APR79 PTZ*)
end;
OLDNWORDS := MAINCODE.NWORDS; (*28AUG79 PTZ*)
IPTR := MAINCODE.FIRST;
CURPC := SEG_EP_RELPC;
while IPTR <> nil do
begin
if COLLAPSIBLE_OP[IPTR↑.OPCODE] and not NO_COLLAPSE_MOV_FLG then
COLLAPSE_MOV_OPT(IPTR); (*can modify IPTR*)
if ((IPTR↑.OPCODE = XINC_S) or (IPTR↑.OPCODE = XDEC_S))
and not NO_INC_SKP_FLG then
INC_SKP_OPT(IPTR); (*can modify IPTR*)
IPTR := IPTR↑.NEXTPTR;
end (*while IPTR <> nil do*);
PROC_WDS_REMOVED := PROC_WDS_REMOVED + (OLDNWORDS - MAINCODE.NWORDS);
(*28AUG79 PTZ*)
(* The rest of the peephole optimizer - at most MAXPEEPASSES -
does a straightforward collapse of skips around JMPAs that
are short enough to be a skip alone. A small amount of testing
shows that the first pass gets about 90 percent of the cases
and the second pass gets a few percent more, etc.
We don't combine this optimization with the previous group
because keeping track of the PC while deleting instructions
and pieces of instructions is difficult *)
PASS2_MAXPC := SEG_EP_RELPC + WORDUNITS*MAINCODE.NWORDS;
CHANGES := true;
PEEP_PASSES := 0;
while CHANGES and (PEEP_PASSES < MAXPEEP_PASSES) do
begin
if TR_PEEPHOLE then (*14JAN79 PTZ*)
begin
WRITELN(OUTPUT);
WRITELN(OUTPUT,'-------------------------');
WRITELN(OUTPUT,'before peephole pass ',PEEP_PASSES+2:2,':');
WRITELN(OUTPUT,'-------------------------');
PRINTMAINCODE (*28APR79 PTZ*)
end;
OLDNWORDS := MAINCODE.NWORDS;
IPTR := MAINCODE.FIRST;
CURPC := SEG_EP_RELPC;
while IPTR <> nil do
begin
if IPTR↑.OPFMT = VFAKEOP then
begin
if IPTR↑.OPCODE = XS1LOC then
IPTR↑.FAKEOPND := CURPC
end
else
begin
if (IPTR↑.OPFMT = VSOP) and not NO_SKIP_JMPA_FLG then
SKIP_JMPA_OPT(IPTR,CURPC)
end;
CURPC := CURPC + INSTR_WORDS(IPTR,CURPC)*WORDUNITS;
IPTR := IPTR↑.NEXTPTR
end (*while IPTR <> nil do*);
CHANGES := (OLDNWORDS <> MAINCODE.NWORDS);
PASS2_MAXPC := CURPC;
PROC_WDS_REMOVED := PROC_WDS_REMOVED + (OLDNWORDS - MAINCODE.NWORDS);
(*28AUG79 PTZ*)
PEEP_PASSES := PEEP_PASSES + 1
end;
end (*PEEPHOLE_OPTIMIZER*);
(** OBJECT_MODULE_SEGMENT_CLASS: CONCPAS3 PASS3PCRELFIX INSERT_NOP **)
(**)
procedure CONCPAS3; (*PTZ*) (*DATASTRCH*)
var SKPOFF : MINSKPOFFSET..MAXSKPOFFSET;
JMPOFF : integer;
TOPND : OPERAND;
NXTIPTR, LASTPTR, JUMPSKIPDEST : AN_INSTREC;
FORCE2 : boolean;
SAVEIWDS : IWDRNG; (*28AUG79 PTZ*)
procedure PASS3PCRELFIX (var OPND : INSTOPND); (*DATASTRCH*)
(*Examine the extended non-constant S1 operand in INSTOPND.
If it is PC relative, fix it up by subtracting
the current PC value from the displacement.*)
var VBIT : BIT;
begin
if not (OPND.XWD <> nil) then
ASSERTFAIL('PASS3PCRE001');
with OPND.XWD↑ do
begin
VBIT := V;
if ((OPND.REG = 0) and (OPND.F = S1RPC))
or ((V = 1) and (REG = S1RPC)) then
if V = 1 then
DISP := DISP - CURPC
else
if ADDR >= CURPC then
ADDR := ADDR - CURPC
else
ADDR := ADDR - CURPC + (MAXS1ADDR+1)
end
end (*PASS3PCRELFIX*);
procedure INSERT_NOP;
(*Insert a single word no-op in the code immediately following
the word at LASTPTR, updating NXTPC (and MAINCODE.NWORDS).*)
var OPND : OPERAND;
begin
INSERTXOP(LASTPTR,XNOP,UNUSED_OP,UNUSED_OP); (*LCW*)
NXTPC := NXTPC + WORDUNITS
end (*INSERT_NOP*);
begin (*CONCPAS3*) (*DATASTRCH*)
if TR_PEEPHOLE then (*14JAN79 PTZ*)
begin
WRITELN(OUTPUT);
WRITELN(OUTPUT,'-------------------------');
WRITELN(OUTPUT,'before final concretizer:');
WRITELN(OUTPUT,'-------------------------');
PRINTMAINCODE (*28APR79 PTZ*)
end;
IPTR := MAINCODE.FIRST;
CURPC := SEG_EP_RELPC;
while IPTR <> nil do
begin
with IPTR↑ do
begin
NXTIPTR := NEXTPTR; (*in case we insert some NOPs*)
NXTPC := CURPC;
SAVEIWDS := IWDS; (*28AUG79 PTZ*)
if OPFMT = VFAKEOP then
begin
if OPCODE = XS1LOC then
begin
if not (FAKEOPND = CURPC) then
ASSERTFAIL('CODE_CONC002')
end
end
else (*not VFAKEOP*)
begin
NXTPC := NXTPC + WORDUNITS;
if INSTOPND1.XWD <> nil then
begin (*extended OPND1*)
NXTPC := NXTPC + WORDUNITS;
if not
((INSTOPND1.F > 0) and (INSTOPND1.REG = 1))
then
PASS3PCRELFIX(INSTOPND1);
end;
if INSTOPND2.XWD <> nil then
begin (*extended OPND2*)
NXTPC := NXTPC + WORDUNITS;
if not
((INSTOPND2.F > 0) and (INSTOPND2.REG = 1))
then
PASS3PCRELFIX(INSTOPND2);
end;
if OPFMT = VSOP then
begin (*any VSOP*)
JUMPSKIPDEST := DESTPTR;
if JUMPSKIPDEST <> nil then
begin
if not (JUMPSKIPDEST↑.OPCODE = XS1LOC) then
ASSERTFAIL('CODE_CONC003');
TPC := JUMPSKIPDEST↑.FAKEOPND;
if not (TPC <> S1LOCUNDEF) then
ASSERTFAIL('CODE_CONC004');
SKPOFF := (TPC-CURPC) div WORDUNITS;
if not ((MINSKPOFFSET<=SKPOFF)
and (SKPOFF<=MAXSKPOFFSET)) then
ASSERTFAIL('CODE_CONC005');
SKP := SKPOFF
end
end (*any VSOP*)
else if OPFMT = VJOP then
begin (*any VJOP*)
LASTPTR := IPTR;
JUMPSKIPDEST := DESTPTR;
FORCE2 := (PR = 1) (*force two-word jump*);
if JUMPSKIPDEST = nil then
(*no JUMPDEST: leave alone except FORCE2*)
PR := 0
else
begin
if not (JUMPSKIPDEST↑.OPCODE = XS1LOC) then
ASSERTFAIL('CODE_CONC006');
TPC := JUMPSKIPDEST↑.FAKEOPND;
if not (TPC <> S1LOCUNDEF) then
ASSERTFAIL('CODE_CONC007');
JMPOFF := (TPC-CURPC) div WORDUNITS;
if (MINJPROFFSET<=JMPOFF) and (JMPOFF<=MAXJPROFFSET)
and (INSTOPND2.XWD = nil) then
begin (*PR-style jump*)
PR := 1;
J := JMPOFF
end (*PR-style jump*)
else
begin (*non PR-style jump*)
PR := 0;
if INSTOPND2.XWD = nil then
begin (*build an extended OPND2*)
if not (MAINCODE.NWORDS > MAXJPROFFSET) then
ASSERTFAIL('CODE_CONC010');
NXTPC := NXTPC + WORDUNITS;
(*EJG 17JAN79*) XTNDED_REGDISP_OPERAND(TOPND, S1RPC, -CURPC);
new(INSTOPND2.XWD);
INSTOPND2.XWD↑ := TOPND.XW;
(*should have already been IWDS := IWDS + 1;
counted... 28AUG79 PTZ MAINCODE.NWORDS := MAINCODE.NWORDS + 1*)
end (*build an extended OPND2*);
INSTOPND2.XWD↑.DISP := INSTOPND2.XWD↑.DISP + TPC
end (*non PR-style jump*);
end (*valid JUMPDEST*);
if FORCE2 then
begin (*force two-word jump*)
while NXTPC-CURPC < 2*WORDUNITS do
begin
INSERT_NOP;
IWDS := IWDS - 1; (*this used to be counted in*)
(*the JOP instr*) (*28AUG79 PTZ*)
end;
if not (NXTPC-CURPC = 2*WORDUNITS) then
ASSERTFAIL('CODE_CONC008')
(*else was already > 2 words*)
end (*force two-word jump*)
else
begin (*normal jump*)
if IWDS <> (NXTPC - CURPC) div WORDUNITS then
begin
if (PR = 1) and (MAINCODE.NWORDS > MAXJPROFFSET)
then
(*We assumed extended OPND2,
but managed to emit PR-style -
so insert NOP to keep PC straight*)
begin
INSERT_NOP;
IWDS := IWDS - 1; (*this used to be counted in*)
(*the JOP instr*) (*28AUG79 PTZ*)
end;
end
end (*normal jump*)
end (*any VJOP*)
end (*not VFAKEOP*);
if not (CURPC + SAVEIWDS * WORDUNITS = NXTPC) then (*28AUG79 PTZ*)
ASSERTFAIL('CODE_CONC011');
end (*with IPTR↑ do*);
IPTR := NXTIPTR;
CURPC := NXTPC
end (*while IPTR <> nil do*);
if not (PASS2_MAXPC = CURPC) then ASSERTFAIL('CODE_CONC009');
end (*CONCPAS3*);
begin (*CODE_CONCRETIZER*) (*28APR79 PTZ...*)
PROC_WDS_REMOVED := 0;
CONCPAS1;
PEEPHOLE_OPTIMIZER;
CONCPAS3;
JUMPS_CONCRETIZED := true;
INSTR_WDS_REMOVED := INSTR_WDS_REMOVED + PROC_WDS_REMOVED;
end (*CODE_CONCRETIZER*); (*...28APR79 PTZ*)
(** OBJECT_MODULE_SEGMENT_CLASS: INIT_SEGMENT GEN_SEGMENT FIXDISP OPEN_SEGMENT CLOSE_SEGMENT CLEAROUT_TXTBUF OPEN_TXT CLOSE_TXT OUT_TXT **)
(**)
procedure INIT_SEGMENT;
var R : S1REGISTER;
G : S1GBL;
H : integer;
S1X : S1Q..S1D;
begin
NEW(OLDNP);
MAINCODE := EMPTYINSTLIST; (*DATASTRCH*)
ALL_CODE_EMITTED := false; (*DATASTRCH*)
JUMPS_CONCRETIZED := false;
MAKE_NEWINSTREC(NEWINSTREC); (*DATASTRCH*)
STRINGAREA := EMPTYCODELIST;
NXTSTRDISP := 0;
STRINGFIXLIST := EMPTYOPNDXWORDFIXLIST; (*DATASTRCH*)
TOP := BOT-1;
for R := FIRSTS1REG to LASTS1REG do
begin
RISFREE[R] := true;
RPWORD[R] := RSINGLE; (*PBK*)
end;
for G := FIRSTS1GBL to LASTS1GBL do
begin
GISFREE[G] := true;
end;
MINTMPS1REG := MINPARS1REG;
for H := 0 to LBLHTSIZEM1 do
LBLHASHTAB[H] := nil;
EVALSAVE.SIZE := 0;
EVALSAVE.FIXLIST := EMPTYOPND2FIXLIST; (*DATASTRCH*)
EVALSAVE.NEGFIXLIST := EMPTYOPND2FIXLIST; (*DATASTRCH*)
NEG_SHIFT_FIXLIST := EMPTYOPND2FIXLIST; (*DATASTRCH*)
MSTTOP := 0;
REALTBL := EMPTYCODELIST;
SETTBL := EMPTYCODELIST;
LOCTBL := EMPTYCODELIST;
REALFIXLIST := EMPTYOPNDXWORDFIXLIST; (*DATASTRCH*)
SETFIXLIST := EMPTYOPNDXWORDFIXLIST; (*DATASTRCH*)
PROCTBL.NPROCS := 0;
STACKFRAME.SIZE := 0; (*als/peg 25jul79..*)
STACKFRAME.FIXLIST := EMPTYOPND2FIXLIST; (*DATASTRCH*)
STACKFRAME.NEGFIXLIST := EMPTYOPND2FIXLIST; (*...als/peg 25jul79*)(*DATASTRCH*)
MSTSTK[MSTTOP].EVALSAVESTART := 0;
BOUNDTBL := EMPTYCODELIST;
BOUNDFIXLIST := EMPTYOPNDXWORDFIXLIST; (*DATASTRCH*)
PROCTBL.FIRST := nil;
end (*INIT_SEGMENT*);
procedure GEN_SEGMENT;
const
MAXTXTBUFNWORDS = 4; (*for TXT records to fit in 80 columns*)
var
PTR : A_CODEREC; (*DATASTRCH*)
OXPTR : AN_OPNDXWORDREC; (*DATASTRCH*)
O2PTR : AN_OPND2REC; (*DATASTRCH*)
IPTR, NXTIPTR : AN_INSTREC; (*DATASTRCH*)
OPLOC : AN_OPERANDXWORD; (*DATASTRCH*)
VAL, DSP : integer;
I : 0..LBLHTSIZEM1;
LPTR : A_LBLHASHENT;
PPTR : A_PROCENT;
ASMPC, NXTPC, MAXPC : integer;
PITPC : integer; (*address of PIT in segment*)
S1PC : integer;
NREF, INX : integer;
CURS1OPC : S1OPCODE;
ICW, W, W1, W2 : S1WORD;
TXTBUF : array [1..MAXTXTBUFNWORDS] of S1WORD;
TXTBUFNWORDS : 0..MAXTXTBUFNWORDS;
TXTBUFFSTADR : S1RELADR;
TXTBUFNXTADR : S1RELADR;
TADR : integer; (*31AUG79 PTZ*)
SSTR : CHAR4;
SLOC : CHAR10;
SWORD : CHAR12;
S1X : S1Q..S1D;
INSTPI : INSTREC_PTRINT; (*31AUG79 PTZ...*)
NEWNP : AN_INSTREC;
HEAPTOP, HEAPBOTTOM : integer; (*...31AUG79 PTZ*)
procedure DISASM(NXTCP : INTEGER; PTR : A_CODEREC); (*28DEC78 ALS*)
begin
CVOS_10(SLOC,NXTPC);
WRITE(OUTPUT,SLOC,' : ');
ICW := PTR↑.CODEWORD;
CVOS_S1WORD_12(SWORD,ICW);
WRITE(OUTPUT,SWORD,' ');
end (* DISASM *);
procedure DISASM2(PTR : A_CODEREC); (*28DEC78 ALS*)
var
K, KWID : INTEGER;
begin
ICW := PTR↑.CODEWORD;
K := GETFIELD(ICW,WORDBITS-(BITS_ON_COMP_MACH-1),
BITS_ON_COMP_MACH - 1);
KWID := FLDW(K);
WRITE(OUTPUT,K:KWID,'.');
WRITELN(OUTPUT);
end (* DISASM2 *);
procedure FIXDISP(WORDLOC : AN_OPERANDXWORD; FIXVAL : integer);(*DATASTRCH*)
(*Fix up the extended word addressed by WORDLOC by adding the
FIXVAL to the displacement.*)
var DSP : integer;
begin
DSP := WORDLOC↑.DISP; (*DATASTRCH*)
DSP := DSP + FIXVAL;
if (DSP > MAXS1DISP) or (DSP < MINS1DISP) then
ERROR(WINVALID_DISPLACEMENT)
else
WORDLOC↑.DISP := DSP; (*DATASTRCH*)
end (*FIXDISP*);
procedure OPEN_SEGMENT(NESD, NTXT, NESR, NRLD : integer);
(*Prepare to output the segment. NESD is the number of
external symbols which will be defined. NTXT is the number
of words of TXT which will be output. NESR is the number of
external symbols which will be referenced. NRLD is the
number of words which will be relocated. If any of these
parameters is not known exactly, specify -1.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_SEGMENT*);
procedure CLOSE_SEGMENT;
(*Close segment output.*)
begin
(* The following SIN record should be output when S-1 runtimes
exist for finding compilation date and time - see LDI-5:
WRITELN(PRR,'SIN COMPILER 0 ',compilation date,' ',
compilation time,' ',SOPA_NAME:8,' ',SOPA_VERSION:2,
' ',SOPA_MODLEVEL:2); *) (*23JUL79 PTZ*)
WRITELN(PRR,'EOM ',CURPROCXN.NAM,' WRITER-ID: ',
SOPA_ID); (*temporarily*) (*23JUL79 PTZ*)
end (*CLOSE_SEGMENT*);
procedure CLEAROUT_TXTBUF;
(*Clear out the TXTBUF by outputting a TXT record if any text
is contained therein. Count the words output.*) (*LCW*)
var I : 1..MAXTXTBUFNWORDS;
S_FSTADR : CHAR12;
S_TXTBFW : CHAR12;
begin
WORD_CNT := WORD_CNT + TXTBUFNWORDS; (*LCW*)
if TXTBUFNWORDS > 0 then
begin
CVOS_12(S_FSTADR,TXTBUFFSTADR);
WRITE(PRR,'TXT ',1:8,' ',S_FSTADR,' ',TXTBUFNWORDS:2);
for I := 1 to TXTBUFNWORDS do
begin
CVOS_S1WORD_12(S_TXTBFW,TXTBUF[I]);
WRITE(PRR,' ',S_TXTBFW);
end;
WRITELN(PRR);
TXTBUFNWORDS := 0
end
end (*CLEAROUT_TXTBUF*);
procedure OPEN_TXT;
(*Prepares to output the TXT part of the module.*)
begin
TXTBUFNWORDS := 0
end (*OPEN_TXT*);
procedure CLOSE_TXT;
(*Closes off all pending TXT part output.*)
begin
CLEAROUT_TXTBUF
end (*CLOSE_TXT*);
procedure OUT_TXT(var ADR : S1RELADR; WORD : S1WORD);
(*Outputs the word WORD as part of a TXT record, to be loaded
at address ADR. Increments ADR by WORDUNITS to prepare for
next word.*)
begin
if (TXTBUFNWORDS >= MAXTXTBUFNWORDS) or (ADR <> TXTBUFNXTADR)
then
CLEAROUT_TXTBUF;
if TXTBUFNWORDS = 0 then
begin
TXTBUFFSTADR := ADR;
TXTBUFNXTADR := ADR
end;
TXTBUFNWORDS := TXTBUFNWORDS + 1;
TXTBUF[TXTBUFNWORDS] := WORD;
ADR := ADR + WORDUNITS;
TXTBUFNXTADR := ADR
end (*OUT_TXT*);
(** OBJECT_MODULE_SEGMENT_CLASS: OPN_SEG CLS_SEG OUT_SEG OPEN_ESD CLS_ESD OUT_ESD OPEN_ESR CLS_ESR OUT_ESR OPEN_RLD CLOSE_RLD OUT_RLD **)
(**)
procedure OPN_SEG;
(*Prepares to output the SEG part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPN_SEG*);
procedure CLS_SEG;
(*Closes off all pending SEG part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLS_SEG*);
procedure OUT_SEG(LSNAM : ALFA; STYP : ZSEGTYPE;
SEGINX : ESDINDEX; SADR : S1RELADR;
SLEN : integer; SACMOD : CHAR17);
(*Outputs a SEG entry for symbol SNAM of type STYP, segment
index SEGINX, address SADR, and length SLEN.*)
var S_SADR, S_SLEN : CHAR12;
SNAM : ZSYMBOL;
I : ALFALEN;
begin
for I := 1 to 8 do (*als/peg 25jul79*)
SNAM[I] := LSNAM[I]; (*als/peg 25jul79*)
CVOS_12(S_SADR, SADR);
CVOS_12(S_SLEN, SLEN);
WRITELN(PRR,'SEG ',SNAM:8,' ',ZSEGTYPE_TO_CHARS[STYP]:4,
' ',SEGINX:8,' ',S_SADR,' ',S_SLEN,' ',SACMOD);
end (*OUT_SEG*);
procedure OPEN_ESD;
(*Prepares to output the ESD part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_ESD*);
procedure CLS_ESD;
(*Closes off all pending ESD part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLS_ESD*);
procedure OUT_ESD(LSNAM : ALFA; STYP : ZESDTYPE;
SEGINX : ESDINDEX; SADR : S1RELADR;
INX : ESDINDEX);
(*Outputs an ESD entry for symbol SNAM of type STYP, segment
index SEGINX, address SADR, and index INX.*)
var S_SADR : CHAR12;
SNAM : ZSYMBOL;
I : ALFALEN;
begin
for I := 1 to 8 do (*als/peg 25jul79*)
SNAM[I] := LSNAM[I]; (*als/peg 25jul79*)
CVOS_12(S_SADR, SADR);
WRITELN(PRR,'ESD ',SNAM:8,' ',ZESDTYPE_TO_CHARS[STYP]:4,
' ',SEGINX:8,' ',S_SADR,' ',INX:8);
end (*OUT_ESD*);
procedure OPEN_ESR;
(*Prepares to output the ESR part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_ESR*);
procedure CLS_ESR;
(*Closes off all pending ESR part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLS_ESR*);
procedure OUT_ESR(LSNAM : ALFA; STYP : ZESRTYPE;
INX : ESRINDEX);
(*Outputs an ESR entry for symbol SNAM of type STYP and index
INX.*)
var SNAM : ZSYMBOL;
I : ALFALEN;
begin
for I := 1 to 8 do (*als/peg 25jul79*)
SNAM[I] := LSNAM[I]; (*als/peg 25jul79*)
WRITELN(PRR,
'ESR ',SNAM:8,' ',ZESRTYPE_TO_CHARS[STYP]:4,' ',INX:8)
end (*OUT_ESR*);
procedure OPEN_RLD;
(*Prepares to output the RLD part of the module.*)
begin
(*No-op for now with the intermediate loader format*)
end (*OPEN_RLD*);
procedure CLOSE_RLD;
(*Closes off all pending RLD part output.*)
begin
(*No-op for now with the intermediate loader format*)
end (*CLOSE_RLD*);
procedure OUT_RLD(LSNAM : ALFA; IXFLAG : ZESDESRSEG;
SOPR : ZOPR; SEGINX : ESDINDEX;
SADR : S1RELADR; INX : ZINDEX);
(*Outputs an RLD entry for symbol SNAM of type IXFLAG, operation
SOPR, segment index SEGINX, address SADR, and index INX.*)
var S_SADR : CHAR12;
SNAM : ZSYMBOL;
I : ALFALEN;
begin
for I := 1 to 8 do (*als/peg 25jul79*)
SNAM[I] := LSNAM[I]; (*als/peg 25jul79*)
CVOS_12(S_SADR, SADR);
WRITELN(PRR,'RLD ',SNAM:8,' ',ZIXFLAG_TO_CHAR[IXFLAG]:1,
' ',ZOPR_TO_CHARS[SOPR]:2,' ',SEGINX:8,
' ',S_SADR,' ',INX:8)
end (*OUT_RLD*);
begin (*GEN_SEGMENT*)
ALL_CODE_EMITTED := true; (*DATASTRCH*)
O2PTR := EVALSAVE.FIXLIST.FIRST; (*DATASTRCH*)
while O2PTR <> nil do (*DATASTRCH*)
begin
FIXOPND2(O2PTR↑.OPND2IPTR,EVALSAVE.SIZE); (*DATASTRCH*)
O2PTR := O2PTR↑.NEXTPTR (*DATASTRCH*)
end;
O2PTR := EVALSAVE.NEGFIXLIST.FIRST; (*DATASTRCH*)
VAL := - EVALSAVE.SIZE;
while O2PTR <> nil do (*DATASTRCH*)
begin
FIXOPND2(O2PTR↑.OPND2IPTR,VAL); (*DATASTRCH*)
O2PTR := O2PTR↑.NEXTPTR (*DATASTRCH*)
end;
O2PTR := STACKFRAME.FIXLIST.FIRST; (*DATASTRCH8/6*)
while O2PTR <> nil do (*DATASTRCH8/6*)
begin
FIXOPND2(O2PTR↑.OPND2IPTR,STACKFRAME.SIZE); (*DATASTRCH8/6*)
O2PTR := O2PTR↑.NEXTPTR (*DATASTRCH8/6*)
end;
O2PTR := NEG_SHIFT_FIXLIST.FIRST; (*DATASTRCH*)
while O2PTR <> nil do (*DATASTRCH*)
begin (*DATASTRCH*)
OPLOC := O2PTR↑.OPND2IPTR↑.INSTOPND2.XWD;
if not (OPLOC<>nil) then ASSERTFAIL('GEN_SEGME001');
DSP := OPLOC↑.DISP;
DSP := (-DSP) * DALIGNMUL;
OPLOC↑.DISP := DSP;
O2PTR := O2PTR↑.NEXTPTR (*DATASTRCH*)
end;
(*Check for undefined labels*)
for I := 0 to LBLHTSIZEM1 do
begin
LPTR := LBLHASHTAB[I];
while LPTR <> nil do
begin
if not LPTR↑.DEFINED then
begin
ERRINT1 := LPTR↑.LBLNUM;
ERROR(WL_LPTR_LBLNUM_UNDEFINED)
end;
LPTR := LPTR↑.NEXTPTR
end;
end (*for I := 0 to LBLHTSIZEM1*);
if TOP <> BOT-1 then
ERROR (WSTACK_LEFT_NONEMPTY_IN_LAST_SEGMENT);
if MSTTOP <> 0 then
ERROR (WMST_WITHOUT_CUP_IN_LAST_SEGMENT);
CODE_CONCRETIZER;
(** OBJECT_MODULE_SEGMENT_CLASS **)
(**)
ASMPC := CURPC; (*save for reporting literals if ASM on*) (*28AUG79 PTZ*)
(*Resolve string, real, set literals...*)
OXPTR := STRINGFIXLIST.FIRST; (*DATASTRCH*)
while OXPTR <> nil do (*DATASTRCH*)
begin
FIXDISP(OXPTR↑.XWORDPTR,CURPC); (*DATASTRCH*)
OXPTR := OXPTR↑.NEXTPTR (*DATASTRCH*)
end;
CURPC := CURPC + STRINGAREA.NWORDS * WORDUNITS;
OXPTR := REALFIXLIST.FIRST; (*DATASTRCH*)
while OXPTR <> nil do (*DATASTRCH*)
begin
FIXDISP(OXPTR↑.XWORDPTR,CURPC); (*DATASTRCH*)
OXPTR := OXPTR↑.NEXTPTR (*DATASTRCH*)
end;
CURPC := CURPC + REALTBL.NWORDS * WORDUNITS;
OXPTR := SETFIXLIST.FIRST; (*DATASTRCH*)
while OXPTR <> nil do (*DATASTRCH*)
begin
FIXDISP(OXPTR↑.XWORDPTR,CURPC); (*DATASTRCH*)
OXPTR := OXPTR↑.NEXTPTR (*DATASTRCH*)
end;
CURPC := CURPC + SETTBL.NWORDS * WORDUNITS;
OXPTR := BOUNDFIXLIST.FIRST; (*DATASTRCH8/6*)
while OXPTR <> nil do (*DATASTRCH*)
begin
FIXDISP(OXPTR↑.XWORDPTR,CURPC); (*DATASTRCH*)
OXPTR := OXPTR↑.NEXTPTR (*DATASTRCH*)
end;
CURPC := CURPC + BOUNDTBL.NWORDS * WORDUNITS;
PITPC := CURPC;
if DEBUG then
begin
IPTR := MAINCODE.FIRST;
S1PC := SEG_EP_RELPC;
while IPTR <> nil do
begin
CURS1OPC := IPTR↑.OPCODE; (*DATASTRCH*)
case OPFORMAT[CURS1OPC] of
VFAKEOP:
if CURS1OPC = XPLOC then
begin (*might emit PLOCs also*)
INTEGER_TO_S1WORD(W,S1PC);
EMIT_S1WORD(LOCTBL,W)
end
(*else ignore it*);
VTOP, VXOP, VSOP:
begin
S1PC := S1PC + WORDUNITS;
if IPTR↑.INSTOPND1.XWD <> nil then (*DATASTRCH*)
S1PC := S1PC + WORDUNITS;
if IPTR↑.INSTOPND2.XWD <> nil then (*DATASTRCH*)
S1PC := S1PC + WORDUNITS
end (*VTOP, VXOP, VSOP*);
VJOP:
begin
S1PC := S1PC + WORDUNITS;
if IPTR↑.INSTOPND1.XWD <> nil then (*DATASTRCH*)
S1PC := S1PC + WORDUNITS;
if (IPTR↑.PR = 0)and(IPTR↑.INSTOPND2.XWD <> nil) then (*DATASTRCH*)
S1PC := S1PC + WORDUNITS
end (*VJOP*)
end (*case*);
IPTR := IPTR↑.NEXTPTR; (*DATASTRCH*)
end (*while IPTR <> nil*);
CURPC := CURPC + LOCTBL.NWORDS * WORDUNITS
end (*if DEBUG*);
if ASM then
begin
WRITELN(OUTPUT,'************************** ;START OF ',
CURPROCXN.NAM,' ',CURPROC);
WRITELN(OUTPUT,'************************** ;WRITER-ID: ',
SOPA_ID); (*23JUL79 PTZ*)
IPTR := MAINCODE.FIRST;
S1PC := SEG_EP_RELPC;
while IPTR <> nil do
begin
DISASSEMBLE(S1PC,IPTR);
IPTR := IPTR↑.NEXTPTR; (*DATASTRCH*)
end (*while IPTR <> nil*);
(*To report all strings in .PS1*) (*22DEC78 ALS*)
PTR := STRINGAREA.FIRST;
NXTPC := ASMPC;
if PTR <> nil then WRITELN(OUTPUT);
while PTR <> nil do
begin
DISASM(NXTPC,PTR);
WRITE(OUTPUT,'ASCII /');
CVCHR_S1WORD_4(SSTR,ICW);
WRITE(OUTPUT,SSTR,'/');
WRITELN(OUTPUT);
NXTPC := NXTPC+WORDUNITS;
PTR := PTR↑.NEXTPTR
end (*while PTR <> nil for STRINGAREA*);
PTR := REALTBL.FIRST;
if PTR <> nil then WRITELN(OUTPUT);
while PTR <> nil do
begin
DISASM(NXTPC,PTR);
WRITE(OUTPUT,' ;REAL LITERAL ');
DISASM2(PTR);
NXTPC := NXTPC+WORDUNITS;
PTR := PTR↑.NEXTPTR
end (*while PTR <> nil for REALTBL*);
PTR := SETTBL.FIRST;
if PTR <> nil then WRITELN(OUTPUT);
while PTR <> nil do
begin
DISASM(NXTPC,PTR);
WRITE(OUTPUT,' ;SET LITERAL ');
DISASM2(PTR);
NXTPC := NXTPC+WORDUNITS;
PTR := PTR↑.NEXTPTR
end (*while PTR <> nil for SETTBL*);
PTR := BOUNDTBL.FIRST;
if PTR <> nil then WRITELN(OUTPUT);
while PTR <> nil do
begin
DISASM(NXTPC,PTR);
WRITE(OUTPUT,' ;BOUND LITERAL ');
DISASM2(PTR);
NXTPC := NXTPC+WORDUNITS;
PTR := PTR↑.NEXTPTR
end (*while PTR <> nil for BOUNDTBL*);
PTR := LOCTBL.FIRST;
if PTR <> nil then WRITELN(OUTPUT);
while PTR <> nil do
begin
DISASM(NXTPC,PTR);
ICW := PTR↑.CODEWORD;
WRITE(OUTPUT,' ;LOC LITERAL ');
DISASM2(PTR);
NXTPC := NXTPC+WORDUNITS;
PTR := PTR↑.NEXTPTR
end (*while PTR <> nil for LOCTBL*);
WRITELN(OUTPUT);
WRITE(OUTPUT,chr(12)) (*12 dec = 14 oct = FF (form feed) *)
end (*if ASM then*)
else (*12AUG79 EJG*)
WRITELN(OUTPUT,'************************** ;COMPILED : ',
CURPROCXN.NAM,' ',CURPROC);
IPTR := MAINCODE.FIRST; (*LCW*)
while IPTR <> nil do (*LCW*)
begin (*LCW*)
S1OP_CNT[IPTR↑.OPCODE] := S1OP_CNT[IPTR↑.OPCODE] + 1;(*LCW*)(*DATASTRCH*)
IPTR := IPTR↑.NEXTPTR; (*DATASTRCH*) (*LCW*)
end; (*LCW*)
(*** Output the segment to the loader file... ***)
MAXPC := CURPC;
NREF := 0; PPTR := PROCTBL.FIRST;
while PPTR <> nil do
begin
NREF := NREF + PPTR↑.FIXLIST.NWORDS;
PPTR := PPTR↑.NEXTPTR
end;
OPEN_SEGMENT(1,MAXPC div WORDUNITS,PROCTBL.NPROCS,2*NREF);
(*Output the SEG entries...*)
OPN_SEG;
OUT_SEG(CURPROCXN.NAM,ZIS,1,SEG_START_RELPC,MAXPC-SEG_START_RELPC,
'IN RA ');
CLS_SEG;
(*Output the ESD entries...*)
OPEN_ESD;
OUT_ESD(CURPROCXN.NAM,ZIN,1,SEG_START_RELPC,1);
CLS_ESD;
(** OBJECT_MODULE_SEGMENT_CLASS **)
(**)
(*Output the TXT entries...*)
OPEN_TXT;
CURPC := SEG_START_RELPC;
ZSYMBOL_TO_S1WORDS(W1,W2,CURPROCXN.NAM);
OUT_TXT(CURPC,W1);
OUT_TXT(CURPC,W2);
W := ZEROS1WORD;
if DEBUG then PUTFIELD(W,0,1,1);
PUTFIELD(W,1,5,LVL_TO_S1REG[CURLVL]);
OUT_TXT(CURPC,W);
INTEGER_TO_S1WORD(W,PITPC);
OUT_TXT(CURPC,W);
IPTR := MAINCODE.FIRST;
if not (CURPC = SEG_EP_RELPC) then ASSERTFAIL('GEN_SEGME002');
while IPTR <> nil do
begin
NXTIPTR := IPTR↑.NEXTPTR; (*DATASTRCH*)
NXTPC := CURPC + IPTR↑.IWDS * WORDUNITS; (*DATASTRCH*)
CURS1OPC := IPTR↑.OPCODE; (*DATASTRCH*)
(* abort if an illegal opcode has been generated *) (*NOV78 PTZ...*)
if not (CURS1OPC <> XILLEGAL) then
ASSERTFAIL('GEN_SEGME003'); (*...NOV78 PTZ*)
if not (OPFORMAT[CURS1OPC] = IPTR↑.OPFMT) then (*DATASTRCH*)
ASSERTFAIL('GEN_SEGME012'); (*DATASTRCH*)
case OPFORMAT[CURS1OPC] of
VFAKEOP:
(*Ignore it*);
VTOP, VXOP, VSOP:
begin
if OPFORMAT[CURS1OPC] = VTOP then
FORMTOP(IPTR) (*DATASTRCH*)
else if OPFORMAT[CURS1OPC] = VXOP then
FORMXOP(IPTR) (*DATASTRCH*)
else if OPFORMAT[CURS1OPC] = VSOP then
FORMSOP(IPTR); (*DATASTRCH*)
OUT_TXT(CURPC,S1INSTBUF[S1INST]); (*DATASTRCH*)
if IPTR↑.INSTOPND2.XWD <> nil then (*DATASTRCH*)
OUT_TXT(CURPC,S1INSTBUF[S1OPND2XWD]); (*extended OPND2*)
if IPTR↑.INSTOPND1.XWD <> nil then (*DATASTRCH*)
OUT_TXT(CURPC,S1INSTBUF[S1OPND1XWD]); (*extended OPND1*)
end (*VTOP, VXOP, VSOP*);
VJOP:
begin
FORMJOP(IPTR); (*DATASTRCH*)
OUT_TXT(CURPC,S1INSTBUF[S1INST]); (*DATASTRCH*)
if (IPTR↑.PR = 0)
and (IPTR↑.INSTOPND2.XWD <> nil) then (*DATASTRCH*)
OUT_TXT(CURPC,S1INSTBUF[S1OPND2XWD]); (*extended OPND2*)
if IPTR↑.INSTOPND1.XWD <> nil then (*DATASTRCH*)
OUT_TXT(CURPC,S1INSTBUF[S1OPND1XWD]); (*extended OPND1*)
end (*VJOP*)
end (*case*);
if not (CURPC = NXTPC) then
ASSERTFAIL('GEN_SEGME007'); (*DATASTRCH*)
IPTR := NXTIPTR;
end (*while IPTR <> nil do*);
PTR := STRINGAREA.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
PTR := REALTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
PTR := SETTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
PTR := BOUNDTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
if not (CURPC = PITPC) then
ASSERTFAIL('GEN_SEGME008'); (*DATASTRCH*)
PTR := LOCTBL.FIRST;
while PTR <> nil do
begin
OUT_TXT(CURPC,PTR↑.CODEWORD);
PTR := PTR↑.NEXTPTR
end;
if not (CURPC = MAXPC) then
ASSERTFAIL('GEN_SEGME009'); (*DATASTRCH*)
CLOSE_TXT;
(*Output the ESR entries...*)
OPEN_ESR;
INX := 1;
PPTR := PROCTBL.FIRST;
while PPTR <> nil do
begin
OUT_ESR(PPTR↑.NAME,ZIR,INX);
INX := INX + 1;
PPTR := PPTR↑.NEXTPTR
end;
CLS_ESR;
(*Output the RLD entries...*)
OPEN_RLD;
INX := 1;
PPTR := PROCTBL.FIRST;
while PPTR <> nil do
begin
OXPTR := PPTR↑.FIXLIST.FIRST; (*DATASTRCH*)
while OXPTR <> nil do
begin
TADR := -OXPTR↑.XWORDPTR↑.ADDR (*DATASTRCH*)
+ SEG_EP_RELPC + WORDUNITS;
if TADR < 0 then (*this is 30-bit arithmetic*)
TADR := TADR + (MAXS1ADDR + 1); (*DATASTRCH*)
(*A procedure reference operand starts out with a
displacement of SEG_EP_RELPC. During concretization,
it has the PC value subtracted from it. Thus
-OXPTR↑.XWORDPTR↑.ADDR+SEG_EP_RELPC is the PC value of
the JSR instruction (distance from the beginning of
the module), and so adding WORDUNITS yields the PC
value of the operand itself.*) (*DATASTRCH*)
OUT_RLD( PPTR↑.NAME,ZESR, ZPLUS,1,TADR,INX);
(*add callee seg addr*)
OUT_RLD(CURPROCXN.NAM,ZESD,ZMINUS,1,TADR, 1);
(*subtract caller seg addr*)
OXPTR := OXPTR↑.NEXTPTR (*DATASTRCH*)
end;
INX := INX + 1;
PPTR := PPTR↑.NEXTPTR
end;
CLOSE_RLD;
CLOSE_SEGMENT;
OLDINSTREC := nil; (*So debugging class will survive.*)
NEWINSTREC := nil;
TOP := BOT-1;
MSTTOP := 0;
new(NEWNP); (*compute storage used - 31AUG79 PTZ...*)
INSTPI.PTR := NEWNP;
HEAPTOP := INSTPI.INT;
INSTPI.PTR := OLDNP;
HEAPBOTTOM := INSTPI.INT;
TOTAL_STORAGE := TOTAL_STORAGE + (HEAPBOTTOM - HEAPTOP); (*heap grows down*)
NUM_PROCS_COMPILED := NUM_PROCS_COMPILED + 1;
MAX_STORAGE := MAX(MAX_STORAGE,HEAPBOTTOM-HEAPTOP); (*...31AUG79 PTZ*)
(*%IFT D10*)
DISPOSE(OLDNP);
(*%ELSE*)
% RELEASE(OLDNP); \
(*%ENDC*)
end (*GEN_SEGMENT*);
(** CALLSTANDARD_CLASS: SAVE_PARMREGS RESTORE_PARMREGS CALLSTANDARD GENCALL ONE_ARG TWO_SINGLE_ARGS CHECKFILADR ALLOC_EXCESS EXCESS_ARG DEALLOC_EXCESS CHECK_REF_PARM RESULT_PARM **)
(**)
procedure SAVE_PARMREGS;
(*Archive all the parmregs to the parmreg save area
in order to make all variables uniformly addressable,
or in order to free the registers.*)
(* Shortened to use MOVMS_N 5 DEC 78 ALS *)
var LASTPREG : -1..MAXPAREGM1;
OPND1, OPND2 : OPERAND;
begin
with CURPROCSPEC do
begin
LASTPREG := REGPARMAREA div WORDUNITS - 1;
if LASTPREG >= 0 then
begin
REGDISP_OPERAND (OPND1, DISPLAY, R_OFFSET);
REG_OPERAND (OPND2, PRM_TO_S1REG [0]);
EMITXOP (MOVMS_N[LASTPREG+1], OPND1, OPND2);
end;
end;
PREGS_ARCHIVED := true;
end (*SAVE_PARMREGS*);
procedure RESTORE_PARMREGS;
(*Restore the parmregs from the save area.*)
(* Shortened to use MOVMS_N 5 Dec 78 ALS *)
var LASTPREG : -1..MAXPAREGM1;
OPND1, OPND2 : OPERAND;
begin
with CURPROCSPEC do
begin
LASTPREG := REGPARMAREA div WORDUNITS - 1;
if LASTPREG >= 0 then
begin
REG_OPERAND (OPND1, PRM_TO_S1REG [0]);
REGDISP_OPERAND (OPND2, DISPLAY, R_OFFSET);
EMITXOP (MOVMS_N[LASTPREG+1], OPND1, OPND2);
end;
end;
PREGS_ARCHIVED := false;
end (*RESTORE_PARMREGS*);
procedure ALLOC_EXCESS (EXCWRDS : integer); (*moved peg 23sep79...*)
(*Allocate stack space for EXCWRDS excess parameter words.*)
var OPND2 : OPERAND;
begin
IMM_OPERAND (OPND2, EXCWRDS*WORDUNITS);
EMITXOP (XADJSP_UP, OPNDRSP, OPND2)
end (*ALLOC_EXCESS*);
procedure DEALLOC_EXCESS (EXCWRDS : integer);
(*Deallocate EXCWRDS of stack space.*)
var OPND2 : OPERAND;
begin
IMM_OPERAND (OPND2, EXCWRDS*WORDUNITS);
EMITTOP(XSUB_S, 0, OPNDRSP, OPND2);
end (*DEALLOC_EXCESS*); (*...moved peg 23sep79*)
procedure CALLSTANDARD;
(*Figure out which standard procedure is being called, load its
arguments into the proper places, and generate the call.*)
var OPNDR, OPND1, OPND2, OPNDI1, OPNDI2 : OPERAND;
CSP : P_STANDARDPROC;
RESCODESTART : AN_INSTREC; (*DATASTRCH*)
RESTYPE : OPNDTYPE;
SKIPLOC : AN_INSTREC; (*DATASTRCH*)
JUMPLOC : AN_INSTREC; (*ROUND*)
SKIP1LOC, SKIP2LOC : AN_INSTREC; (*DATASTRCH*)
FAKE_REF : boolean;
FAKE_PARMREG : S1REGISTER;
FAKE_PARMDISP : integer;
procedure GENCALL (BOTTOMPARM : STKINX);
(*Load the stack (except for parms)
to prevent side effects, and generate the JSR instruction,
with fixup information.*)
var CSPNAM : NAMEREC;
OPNDR, OPND2 : OPERAND;
begin
REG_OPERAND (OPNDR, LVL_TO_S1REG[2]);
EXT_REGADDR_OPERAND (OPND2, S1RPC, SEG_EP_RELPC); (*EJG*)
OPND2.FIXUP := XTRNSYMFIX;
CSPNAM.NAM := '$PCSP '; (*can be optimized to 'OWN' var*)
CSPNAM.LEN := 8;
CSPNAM.NAM[6] := NAM1.NAM[1];
CSPNAM.NAM[7] := NAM1.NAM[2];
CSPNAM.NAM[8] := NAM1.NAM[3];
UPD_PROCTBL (OPND2.FIXPTR, CSPNAM.NAM);
LOADSTACKEXCEPT (BOTTOMPARM, TOP);
EMITJOP (XJSR, 0, OPNDR, OPND2, nil);
end (*GENCALL*);
procedure ONE_ARG (ARG : STKINX; TYP : OPNDTYPE);
(*Load RTB with the argument, coercing to type TYP as needed.*)
begin
if not RISFREE[S1RTB] and (RTBUSER <> ARG) then
MOVE_AND_FREE_RTB;
COERCE_AND_MOVE_QUANTITY (OPNDRTB, ARG, TYP);
FREEDATUMREGS (ARG);
end (*ONE_ARG*);
procedure TWO_SINGLE_ARGS (ARG1, ARG2 : STKINX;
TYP1, TYP2 : OPNDTYPE);
(*Load RTB with two singleword arguments, coercing as needed.*)
var OPNDR : OPERAND;
begin
if not (not IS_DOUBLE[TYP1] and not IS_DOUBLE[TYP2]) then
ASSERTFAIL('TWO_SINGL001');
COERCE_DATUM (ARG1, TYP1);
if not RISFREE[S1RTB] and not((RTBUSER=ARG1) or (RTBUSER=ARG2))
then MOVE_AND_FREE_RTB;
REG_OPERAND (OPNDR, succ(S1RTB) );
COERCE_AND_MOVE_QUANTITY (OPNDR, ARG2, TYP2);
MOVE_QUANTITY (OPNDRTB, ARG1);
FREEDATUMREGS (ARG1);
FREEDATUMREGS (ARG2);
end (*TWO_SINGLE_ARGS*);
procedure CHECKFILADR (STE : STKINX);
(*Verify that STK[STE] is an address in (1,LCIOFILADR).*)
begin
if STK[STE].DTYPE <> TYPUA then
ERROR (WFILE_ADDRESS_NEEDED)
else if not DAT_IS_FILADR(STE) then
ERROR (WSIO_DIDNT_SEE_FILEADDR);
end (*CHECKFILADR*);
procedure EXCESS_ARG (NUM, TOT : integer;
ARG : STKINX; TYP : OPNDTYPE);
(*Store the argument into the NUMth excess parm location
in a block of TOT, coercing to type TYP if needed.*)
var OPND1 : OPERAND;
begin
REGDISP_OPERAND (OPND1, S1RSP, -(TOT-NUM+1) * WORDUNITS);
COERCE_AND_MOVE_QUANTITY (OPND1, ARG, TYP);
FREEDATUMREGS (ARG);
end (*EXCESS_ARGS*);
procedure CHECK_REF_PARM (STE : STKINX);
(*The datum is the address of a reference parameter
(e.g. for a READ). If the reference parameter
is a local parm in a register, TRANSLATE_LVLDSP
has already changed the address to that of the
corresponding save location. We must finish
the job here by emitting moves in one or two
directions to fake the reference parameter
by a value result parameter. This procedure
merely notes whether such a simulation may be
necessary.*)
var FIRSTPARM : integer;
begin
with STK[STE], CURPROCSPEC do
begin
if not ( DTYPE = TYPUA) then ASSERTFAIL('CHECK_REF001');
FIRSTPARM := R_OFFSET;
if (NVPAS = 0) and (FPA.WHICH = MEM)
and (FPA.MEMADR.LVL = CURLVL)
and (FIRSTPARM <= FPA.MEMADR.DSPLMT)
and (FPA.MEMADR.DSPLMT < FIRSTPARM+REGPARMAREA) then
begin
FAKE_REF := true;
FAKE_PARMDISP := FPA.MEMADR.DSPLMT;
FAKE_PARMREG := PRM_TO_S1REG
[(FPA.MEMADR.DSPLMT - FIRSTPARM) div WORDUNITS];
end
else
FAKE_REF := false;
end (*with*)
end (*CHECK_REF_PARM*);
procedure RESULT_PARM (DTYPE : OPNDTYPE);
(*After completing the standard procedure, copy a
(possibly modified) local regparm back into the
register from the corresponding regparm save
location.
Note : no VALUE_PARM procedure is needed at
present because reference parms are only used
by standard procs if they wish to achieve result
parms.*)
var OPND1, OPND2 : OPERAND;
begin
if not ( FAKE_REF) then ASSERTFAIL('RESLT_PRM001');
REG_OPERAND (OPND1, FAKE_PARMREG);
REGDISP_OPERAND (OPND2, DISPLAY, FAKE_PARMDISP);
EMITXOP (MOV_X_X[DTYPE], OPND1, OPND2)
end (*RESULT_PARM*);
begin (*CALLSTANDARD*)
CSP := NAME_TO_CSP(NAM1);
case CSP of
QATN, QEXP, QSIN, QCOS, QLOG, QSQT, QCLK :
begin
if CSP = QCLK then ONE_ARG (TOP, TYPUJ)
else ONE_ARG (TOP, TYPUR);
GENCALL (TOP);
REG_DATUM (TOP, STK[TOP].CODESTART, STK[TOP].DTYPE,S1RTB);
if CSP = QCLK then ALLOCRG (S1RTB) else ALLOCRP (S1RTB);
RTBUSER := TOP;
RTBDOUB := IS_DOUBLE[STK[TOP].DTYPE];
end (*QATN,...,QCLK*);
QXIT :
begin
ONE_ARG (TOP, TYPUJ);
GENCALL (TOP);
POPTOP;
end (*QXIT*);
QTRP :
begin
SAVE_PARMREGS;
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUJ, TYPUA);
GENCALL (TOP-1);
POPTOP; POPTOP;
RESTORE_PARMREGS;
end (*QTRP*);
QGET, QPUT, QRLN, QWLN : (*FILECH*)
begin
CHECKFILADR (TOP);
GENCALL (TOP);
end (*QGET,...,QWLN*); (*FILECH*)
(*FILECH...*)
QRES, QREW :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUA, TYPUJ);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QRES, QREW*);
(*...FILECH*)
QRDB :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPUA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPUB);
POPTOP;
end (*QRDB*);
QRDC :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPUA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPUC);
POPTOP;
end (*QRDC*);
QRDI :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPUA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPUJ);
POPTOP;
end (*QRDI*);
QRDR :
begin
CHECKFILADR (TOP-1);
CHECK_REF_PARM (TOP);
ONE_ARG (TOP, TYPUA);
GENCALL (TOP-1);
if FAKE_REF then RESULT_PARM (TYPUR);
POPTOP;
end (*QRDR*);
QRDS :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUA, TYPUJ);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QRDS*);
QWRB :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUB, TYPUJ);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QWRB*);
QWRC :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUC, TYPUJ);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QWRC*);
QWRI :
begin
CHECKFILADR (TOP-2);
TWO_SINGLE_ARGS (TOP-1, TOP, TYPUJ, TYPUJ);
GENCALL (TOP-2);
POPTOP; POPTOP;
end (*QWRI*);
QWRR :
begin
POPTOP; (*Ignore fraction length for now. LCW*)
CHECKFILADR (TOP-2);
ALLOC_EXCESS (1);
EXCESS_ARG (1, 1, TOP, TYPUJ);
ONE_ARG (TOP-1, TYPUR);
GENCALL (TOP-2);
DEALLOC_EXCESS (1);
POPTOP; POPTOP;
end (*QWRR*);
QWRS :
begin
CHECKFILADR (TOP-3);
ALLOC_EXCESS (1);
EXCESS_ARG (1, 1, TOP, TYPUJ);
TWO_SINGLE_ARGS (TOP-2, TOP-1, TYPUA, TYPUJ);
GENCALL (TOP-3);
DEALLOC_EXCESS (1);
POPTOP; POPTOP; POPTOP;
end (*QWRS*);
QELN, QEOF :
begin
CHECKFILADR (TOP);
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
GENCALL (TOP);
(*Insert the boolean answer under the FILADR.*)
PUSHTOP;
if not (RISFREE[S1RTB] or (RTBUSER<>TOP-1)) then
ASSERTFAIL('QELN,QEOF001');
STK[TOP] := STK[TOP-1];
(*This works since datum does not include RTB.*)
REG_DATUM (TOP-1, STK[TOP-1].CODESTART,
TYPUB, S1RTB);
STK[TOP-1].BREPRES := BINTVAL;
ALLOCRG (S1RTB);
RTBUSER := TOP-1;
RTBDOUB := false;
end (*QELN, QEOF*);
QRND : (*ROUND...*)
with STK[TOP] do
begin
if not IS_REAL[DTYPE] then ERROR(WROUND_OF_NON_REAL);
if IS_DOUBLE[DTYPE] then ERROR(WNOT_IMPLEMENTED);
if IS_CONSTANT(TOP) then
begin
FPA := ZEROFPA;
FPA.MEMADR.DSPLMT := round(RCNST);
RCNST := 0.0;
DTYPE := TYP;
end (*constant*)
else
begin (*not constant*)
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
ALLOCRG(S1RTB); RTBUSER := TOP;
RESCODESTART := CODESTART;
GET_OPERAND(OPND1, TOP);
REAL_IMM_OPERAND(OPND2, 0.0);
SKIPLOC := NEWINSTREC;
EMITSOP(XSKP_LSS_S, 0, OPND1, OPND2, nil);
REAL_IMM_OPERAND(OPND2, 0.5);
EMITTOP(XFADD_S, 3, OPND1, OPND2);
JUMPLOC := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
FIXSOP(SKIPLOC, NEWINSTREC);
REAL_IMM_OPERAND(OPND2, -0.5);
EMITTOP(XFADD_S, 3, OPND1, OPND2);
FIXJOP(JUMPLOC, NEWINSTREC);
EMITXOP(XFX_DM_S_S, OPNDRTB, OPNDRTB);
FREEREGSBUTTHESE(TOP, [S1RTB]);
REG_DATUM(TOP, RESCODESTART, TYP, S1RTB);
end (*not constant*);
end (*with STK[TOP] do, QRND*); (*...ROUND*)
QSIO :
begin
REGDISP_OPERAND (OPND1,
LVL_TO_S1REG[1],
LCIOFILADR + FILE_OFFSET);
with STK[TOP] do
begin
if DTYPE <> TYPUA then
ERROR (WSIO_WITH_NONADDRESS);
MOVE_QUANTITY (OPND1, TOP);
FREEDATUMREGS (TOP);
RESCODESTART := CODESTART;
STK[TOP] := ZERODATUM;
CODESTART := RESCODESTART;
DTYPE := TYPUA;
NVPAS := 1;
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := 1;
VPA1.VPA.MEMADR.DSPLMT :=
LCIOFILADR + FILE_OFFSET;
end (*with STK[TOP] do*);
end (*QSIO*);
QEIO :
begin
CHECKFILADR (TOP);
POPTOP;
end (*QEIO*);
QNEW :
begin
if not IS_INTEGER[STK[TOP].DTYPE] or
(STK[TOP-1].DTYPE <> TYPUA) then
ERROR (WNEW_MUST_HAVE_ADDR_AND_INT);
COERCE_DATUM (TOP, TYPUJ);
GET_OPERAND (OPND2, TOP);
(*Check alignment.*)
if IS_CONSTANT(TOP) then
begin
if STK[TOP].FPA.MEMADR.DSPLMT
mod WORDUNITS <> 0 then
ERROR (WALIGNMENT_ERROR);
end
else if DEBUG then
begin (*Check at run time.*)
IMM_OPERAND (OPND1, WORDUNITS-1);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_NON_S, 0, OPND1, OPND2, nil);
IMM_OPERAND (OPNDI1, 1);
IMM_OPERAND (OPNDI2, -1);
(*Check 0<=-1<=1 : fake TRAP SELF*)
EMITXOP (XBTRP_0_S, OPNDI1, OPNDI2); (*BNDTRPKLU*)
(* EMITJOP(XHALT,0,UNUSED_OP,ZERO_OP,NEWINSTREC); (*BNDTRPKLU*)
FIXSOP (SKIPLOC, NEWINSTREC);
end (*Check at run time.*);
REG_OPERAND (OPNDR, pred(S1RNP)); (*SP-NP pair*)
EMITXOP (XADJSP_DN, OPNDR, OPND2);
GET_ADDRESS (OPND1, TOP-1);
REG_OPERAND (OPNDR, S1RNP);
EMITXOP (XMOV_S_S, OPND1, OPNDR);
FREEDATUMREGS (TOP); POPTOP;
FREEDATUMREGS (TOP); POPTOP;
end (*QNEW*);
QSAV :
begin
if STK[TOP].DTYPE <> TYPUA then
ERROR (WSAV_NEEDS_ADDR);
GET_ADDRESS (OPND1, TOP);
REG_OPERAND (OPNDR, S1RNP);
EMITXOP (XMOV_S_S, OPND1, OPNDR);
FREEDATUMREGS (TOP);
POPTOP;
end (*QSAV*);
QRST :
begin
if STK[TOP].DTYPE <> TYPUA then
ERROR (WRST_NEEDS_ADDR);
if DEBUG then
begin
ADDR_OPERAND (OPND1, S1RNPMEMADR); (*BNDTRPKLU*)
GET_OPERAND (OPND2, TOP); (*BNDTRPKLU*)
EMITXOP (XBTRP_B_S, OPND1, OPND2); (*BNDTRPKLU*)
(* GET_OPERAND (OPND2, TOP); (*BNDTRPKLU*)
(* ADDR_OPERAND (OPND1, S1RNPMEMADR); (*BNDTRPKLU*)
(* SKIP1LOC := NEWINSTREC; (*BNDTRPKLU*)
(* EMITSOP (XSKP_LSS_S, 0, OPND2, OPND1, nil); (*BNDTRPKLU*)
(* ADDR_OPERAND (OPND1, S1RNPMEMADR+WORDUNITS); (*BNDTRPKLU*)
(* SKIP2LOC := NEWINSTREC; (*BNDTRPKLU*)
(* EMITSOP (XSKP_LEQ_S, 0, OPND2, OPND1, nil); (*BNDTRPKLU*)
(* FIXSOP (SKIP1LOC, NEWINSTREC); (*BNDTRPKLU*)
(* EMITJOP (XHALT, 0, UNUSED_OP, ZERO_OP, (*BNDTRPKLU*)
(* NEWINSTREC); (*BNDTRPKLU*)
(* FIXSOP (SKIP2LOC, NEWINSTREC); (*BNDTRPKLU*)
end (*DEBUG*);
REG_OPERAND (OPNDR, S1RNP);
MOVE_QUANTITY (OPNDR, TOP);
FREEDATUMREGS (TOP);
POPTOP;
end (*QRST*);
end (*case CSP of*);
if (CSP in [QGET,QPUT,QRDB,QRDC,QRDI,QRDR,QRDS,
QRES,QREW,QRLN,QWLN,QWRB,QWRC,QWRI,QWRR,QWRS])
and (TOP <> BOT) then
ERROR (WSTACK_NOT_SINGLE)
else if (CSP in [QTRP,QXIT,QNEW,QSAV,QRST])
and (TOP <> BOT-1) then
ERROR (WSTACK_NON_EMPTY);
end (*CALLSTANDARD*);
(*** ASSEMBLE_NEXT_INSTRUCTION_CLASS: ASMNXTINST ***)
(**)
procedure ASMNXTINST;
var
S1OP, MOVEOP : S1OPCODE;
OPND, OPND1, OPND2, OPNDR, OPNDR1, OPNDR2 : OPERAND;
RESTYPE : OPNDTYPE;
RESCODESTART : AN_INSTREC; (*DATASTRCH*)
RESDBL : boolean;
LOWBOUND, HIGHBOUND : integer; (* peg 07jul79 *)
CORRECT, NO_ERROR, BOOL_IN_STK : boolean; (* peg *)
COMBINABLE, CALCULABLE : boolean;
TOOMUCH1, TOOMUCH2 : boolean;
STE, PARM, UNSIMPLE, SIMPLER, GROUP1, GROUP2 : STKINX;
PTR, NEXT : AN_INSTREC; (*DATASTRCH*)
O2PTR : AN_OPND2REC; (*DATASTRCH*)
INSTLOC, SKIPLOC, JUMPLOC, FALLTHRUJUMP : AN_INSTREC; (*DATASTRCH*)
SKIP1LOC, SKIP2LOC : AN_INSTREC; (*BNDTRPKLU*)(*DATASTRCH*)
TMPJUMPLIST : JUMPLIST;
DEST, DEST1, DEST2, OP1RG, OP2RG, OPRRG : S1REGISTER;
DESTREGS : SETOFS1REGS; (*PEG*)
OP1GBL : S1GBL;
LPTR : A_LBLHASHENT;
ONE_IF_OR : BIT;
MAXFINALIND : INDIRECTION;
PR_BIT : BIT;
SP_TWIDDLE : integer;
SKIPSMALL, SKIPNOTBIG, JUMPDEFAULT, JUMPINDEXED : AN_INSTREC;(*DATASTRCH*)
EXCESS : integer;
CONSTPART : integer;
SHIFTDIST : integer;
I : integer;
STARTBIT : S1BITNUM;
INDEX : SETPART_INDEX; (*setch*)
PREG : S1REGISTER; (* peg 01aug79 *)
LASTREGPARM : STKINX; (* peg 09aug79 *)
LASTPREG, DESTLASTPREG : -1..MAXPAREGM1;
PWORD : NONNEGINT;
PREGS : NUMBER_OF_PAREGS;
DSPL : integer;
OFFSET : integer; (*peg 03aug79*)
LABNUM, LABNUM1, LABNUM2 : LBL_INDEX;
RTBSAVED : boolean;
RTBDATUM : STKINX;
RTBDSPL : integer;
IPTR : AN_INSTREC; (*DATASTRCH*)
S1PC : integer;
XFER_CNT : integer;
PRMTOP : STKINX;
(*** ANI_CLASS: ARITH_1_OPS UABS UNEG UADD UINC UDEC ***)
(**)
procedure ARITH_1_OPS;
begin
case OPC of
UABS, UNEG : (* als/peg 28jun79 *)
with STK[TOP] do
begin
if TYP <> DTYPE then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if not IS_SIGNED_NUM[DTYPE] then ERROR(WABS_OR_NEG_OF_NONSIGNED);
if IS_CONSTANT(TOP) then
begin
if IS_INTEGER[DTYPE] then
if OPC = UABS then
FPA.MEMADR.DSPLMT := ABS(FPA.MEMADR.DSPLMT)
else (*OPC = UNEG*)
FPA.MEMADR.DSPLMT := -FPA.MEMADR.DSPLMT
else (*IS_REAL*)
if OPC = UABS then
RCNST := ABS(RCNST)
else (*OPC = UNEG*)
RCNST := -RCNST
end (*IS_CONSTANT(TOP)*)
else (*not constant*)
begin
GET_OPERAND(OPND2,TOP);
FREEDATUMREGS(TOP);
if IS_DOUBLE[DTYPE] then FINDRP else FINDRG;
REG_OPERAND(OPND1,NXTRG);
if OPC = UABS then S1OP := ABS_X[DTYPE]
else S1OP := NEG_X[DTYPE];
EMITXOP(S1OP,OPND1,OPND2);
REG_DATUM(TOP,CODESTART,DTYPE,NXTRG)
end (*not constant*)
end (*UABS, UNEG*);
UADD : (* als/peg 28jun79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE <> STK[TOP-1].DTYPE then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
if IS_INTEGER[TYP] then
begin
if ((TYP = TYPUJ) or (TYP = TYPUL)) then
ADD_TOP_TWO_DATUMS
else
begin (*TYPUI TYPUK*)
if IS_CONSTANT(TOP-1) or IS_CONSTANT(TOP) then
ERROR(WNOT_IMPLEMENTED);
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, XADD_D, OPND1, OPND2,
true, true, true, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
with STK[TOP] do
REG_DATUM (TOP, CODESTART, TYP, DEST);
end (*TYPUI TYPUK*);
end (*IS_INTEGER*) else
if IS_REAL[TYP] then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
if not (RESTYPE = TYPUR) then ASSERTFAIL('UADD 001');
STK[TOP-1].RCNST := STK[TOP-1].RCNST + STK[TOP].RCNST;
POPTOP;
end
else (*not both constants*)
begin
S1OP := REAL_ARITH_OP[S1SIZE[RESTYPE],OPC];
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST, S1OP, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP,RESCODESTART,RESTYPE,DEST)
end (*not both constants*)
end (*IS_REAL*)
else ERROR(WARITH_ON_WRONG_DT);
end (* UADD *);
UINC, UDEC : (* als/peg 28jun79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if not ((IS_INTEGER[TYP]) or (TYP in [TYPUA,TYPUB,TYPUC])) then
ERROR(WINVAL_U_TYPECODE);
if TYP = TYPUA then
if I1 mod QWBITS <> 0 then ERROR(WALIGNMENT_ERROR)
else I1 := I1 div QWBITS;
if OPC = UDEC then I1 := -I1;
INCREMENT_DATUM (TOP, I1);
end (*UINC,UDEC*);
end (*case OPC of*)
end (*ARITH_1_OPS*);
(*** ANI_CLASS: ARITH_2_OPS USUB ***)
(**)
procedure ARITH_2_OPS;
begin
case OPC of
USUB : (* als/peg 28jun79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE <> STK[TOP-1].DTYPE then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
if IS_INTEGER[TYP] then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := TYP;
if ((TYP = TYPUI) or (TYP = TYPUK)) then
begin
if IS_CONSTANT(TOP-1) or IS_CONSTANT(TOP) then
ERROR(WNOT_IMPLEMENTED);
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, XSUB_D, OPND1, OPND2,
true, true, true, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, RESCODESTART, RESTYPE, DEST);
end (*TYPUI, TYPUK*)
else
begin (*TYPUJ, TYPUL*)
COERCE_INT_DATUM(TOP-1);
COERCE_INT_DATUM(TOP);
COMBINABLE := false;
CALCULABLE := false;
repeat
if (STK[TOP].NVPAS=0) and (STK[TOP].FPA=ZEROFPA) then
COMBINABLE := true
else if IS_CONSTANT(TOP) and (STK[TOP-1].FINALIND=IND0) then
COMBINABLE := true
else
begin (*not combinable*)
CONSTPART := 0;
with STK[TOP-1] do
if FINALIND = IND0 then
begin
CONSTPART := FPA.MEMADR.DSPLMT;
FPA.MEMADR.DSPLMT := 0;
end;
with STK[TOP] do
if FINALIND = IND0 then
begin
CONSTPART := CONSTPART - FPA.MEMADR.DSPLMT;
FPA.MEMADR.DSPLMT := 0;
end;
if (STK[TOP-1].NVPAS=0) and (STK[TOP-1].FPA=ZEROFPA) then
begin (*replace hard zero by const part*)
STK[TOP-1].FPA.MEMADR.DSPLMT := CONSTPART;
CONSTPART := 0;
end
else if (STK[TOP].NVPAS=0) and (STK[TOP].FPA=ZEROFPA) then
begin (*replace hard zero by const part*)
STK[TOP].FPA.MEMADR.DSPLMT := -CONSTPART;
CONSTPART := 0;
end;
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not TOOMUCH1 and not TOOMUCH2 then
CALCULABLE := true
else
begin (*must simplify*)
if not TOOMUCH1 then
begin
UNSIMPLE := TOP;
SIMPLER := TOP-1;
CONSTPART := -CONSTPART;
end
else if not TOOMUCH2 then
begin
UNSIMPLE := TOP-1;
SIMPLER := TOP;
end
else (*select one at random*)
begin
UNSIMPLE := TOP-1;
SIMPLER := TOP;
end;
if CONSTPART <> 0 then
if STK[UNSIMPLE].FINALIND = IND0 then
begin
if not (STK[UNSIMPLE].FPA.MEMADR.DSPLMT=0) then
ASSERTFAIL('USUB 001');
STK[UNSIMPLE].FPA.MEMADR.DSPLMT:=CONSTPART
end
else
begin
if not((STK[SIMPLER].FINALIND=IND0) and
(STK[SIMPLER].FPA.MEMADR.DSPLMT=0)) then
ASSERTFAIL('USUB 002');
STK[SIMPLER].FPA.MEMADR.DSPLMT:=CONSTPART;
end;
SIMPLIFY (UNSIMPLE);
end (*must simplify*);
end (*not combinable*);
until COMBINABLE or CALCULABLE;
if COMBINABLE then
begin
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT - STK[TOP].FPA.MEMADR.DSPLMT;
POPTOP;
STK[TOP].CODESTART := RESCODESTART;
end (*COMBINABLE*)
else
begin (*CALCULABLE*)
ADD_SUB_SINGLE (DEST, XSUB_S, OPND1, OPND2, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM (TOP, RESCODESTART, RESTYPE, DEST);
STK[TOP].FPA.MEMADR.DSPLMT := CONSTPART;
end (*CALCULABLE*);
end (*TYPUJ, YYPUL*);
end (*IS_INTEGER*)
else if IS_REAL[TYP] then
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
STK[TOP-1].RCNST := STK[TOP-1].RCNST - STK[TOP].RCNST;
POPTOP
end
else (*not both constants*)
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
S1OP := REAL_ARITH_OP[S1SIZE[RESTYPE],OPC];
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST, S1OP, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP,RESCODESTART,RESTYPE,DEST)
end (*not both constants*)
else ERROR(WARITH_ON_WRONG_DT);
end (* USUB *);
end (*case OPC of*)
end (*ARITH_2_OPS*);
(*** ANI_CLASS: ARITH_3_OPS UMPY USQR ***)
(**)
procedure ARITH_3_OPS;
begin
case OPC of (*UMPY, USQR*)
UMPY : (* als/peg 28jun79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE <> STK[TOP-1].DTYPE then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
if IS_INTEGER[TYP] then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := TYP;
if ((TYP = TYPUI) or (TYP = TYPUK)) then
begin
if IS_CONSTANT(TOP-1) or IS_CONSTANT(TOP) then
ERROR(WNOT_IMPLEMENTED);
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, XMULT_D, OPND1, OPND2,
true, true, true, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, RESCODESTART, RESTYPE, DEST);
end (*TYPUI TYPUK*)
else
begin (*TYPUJ TYPUL*)
COERCE_INT_DATUM(TOP-1);
COERCE_INT_DATUM(TOP);
COMBINABLE := false;
CALCULABLE := false;
repeat
if IS_CONSTANT(TOP) then
begin
if IS_CONSTANT(TOP-1) then
COMBINABLE := true
else
begin
SHIFTDIST := POWER2(STK[TOP].FPA.MEMADR.DSPLMT);
with STK[TOP-1] do
if (SHIFTDIST>=0) and (FPA.MEMADR.LVL=0) and
(FINALIND = IND0) and
((NVPAS=0) or ((NVPAS=1) and
(VPA1.VSHIFT+SHIFTDIST <= SFLDMAX) )) then
COMBINABLE := true;
end;
end (*constant top*)
else if IS_CONSTANT(TOP-1) then
begin
SHIFTDIST := POWER2(STK[TOP-1].FPA.MEMADR.DSPLMT);
with STK[TOP] do
if (SHIFTDIST>=0) and (FPA.MEMADR.LVL=0) and
(FINALIND = IND0) and
((NVPAS=0) or ((NVPAS=1) and
(VPA1.VSHIFT+SHIFTDIST <= SFLDMAX) )) then
COMBINABLE := true;
end (*constant second from top*);
if not COMBINABLE then
begin
if IS_CONSTANT(TOP-1) and IS_CNST_PLUS_OPND(TOP) then
begin (*const*uncomplicated*)
CONSTPART := STK[TOP].FPA.MEMADR.DSPLMT
* STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP].FPA.MEMADR.DSPLMT := 0;
IMM_OPERAND (OPND1, STK[TOP-1].FPA.MEMADR.DSPLMT);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not (not TOOMUCH2) then ASSERTFAIL('UMPY 001');
CALCULABLE := true;
end (*const*uncomplicated*)
else if IS_CONSTANT(TOP) and IS_CNST_PLUS_OPND(TOP-1) then
begin (*uncomplicated*const*)
CONSTPART := STK[TOP].FPA.MEMADR.DSPLMT
* STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP-1].FPA.MEMADR.DSPLMT := 0;
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
if not (not TOOMUCH1) then ASSERTFAIL('UMPY 002');
IMM_OPERAND (OPND2, STK[TOP].FPA.MEMADR.DSPLMT);
CALCULABLE := true;
end (*const*uncomplicated*)
else
begin (*general case*)
FIT_IN_OPERAND (TOOMUCH1, OPND1, TOP-1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not TOOMUCH1 and not TOOMUCH2 then
begin
CONSTPART := 0;
CALCULABLE := true;
end
else
begin (*must simplify*)
if not TOOMUCH1 then
SIMPLIFY (TOP)
else if not TOOMUCH2 then
SIMPLIFY (TOP-1)
else (*select one at random*)
SIMPLIFY (TOP);
end (*must simplify*);
end (*general case*);
end (*if not COMBINABLE*)
until COMBINABLE or CALCULABLE;
if CALCULABLE then
begin
MULT_SINGLE (DEST, OPND1, OPND2, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, RESCODESTART, RESTYPE, DEST);
STK[TOP].FPA.MEMADR.DSPLMT := CONSTPART;
end (*CALCULABLE*)
else
begin (*COMBINABLE*)
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT * STK[TOP].FPA.MEMADR.DSPLMT;
if (STK[TOP-1].NVPAS=0) and (STK[TOP].NVPAS<>0) then
begin
STK[TOP-1].NVPAS := STK[TOP].NVPAS;
STK[TOP-1].VPA1 := STK[TOP].VPA1;
(*Multiplicands not combinable if 2 VPAs exist*)
end;
with STK[TOP-1] do
begin
if not (NVPAS <= 1) then ASSERTFAIL('UMPY 003');
if NVPAS = 1 then
VPA1.VSHIFT := VPA1.VSHIFT + SHIFTDIST;
CODESTART := RESCODESTART;
end;
POPTOP;
end (*COMBINABLE*);
end (*TYPUJ TYPUL*)
end (*UMPY I*) else
if IS_REAL[TYP] then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
if not (RESTYPE = TYPUR) then ASSERTFAIL('UMPY 004');
STK[TOP-1].RCNST := STK[TOP-1].RCNST * STK[TOP].RCNST;
POPTOP;
end
else (*not both constants*)
begin
S1OP := REAL_ARITH_OP[S1SIZE[RESTYPE],OPC];
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST, S1OP, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP,RESCODESTART,RESTYPE,DEST)
end (*not both constants*);
end (*IS_REAL*)
else ERROR(WARITH_ON_WRONG_DT);
end (*UMPY*);
USQR : (* als/peg 28jun79 *)
with STK[TOP] do
begin
if DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if not (IS_REAL[TYP] or IS_INTEGER[TYP]) then
ERROR(WSQUARE_OF_INVALID_TYPE)
else
begin
if IS_CONSTANT(TOP) then
begin
if TYP in [TYPUI, TYPUK] then ERROR(WNOT_IMPLEMENTED);
if IS_INTEGER[TYP] then
FPA.MEMADR.DSPLMT := sqr(FPA.MEMADR.DSPLMT)
else (*IS_REAL(RESTYPE)*)
RCNST := sqr(RCNST)
end (*IS_CONSTANT(TOP)*)
else (*not constant*)
begin
GET_OPERAND(OPND2,TOP);
if ((TYP = TYPUJ) or (TYP = TYPUL)) then S1OP := XMULT_S
else if ((TYP = TYPUI) or (TYP = TYPUK)) then S1OP := XMULT_D
else if TYP = TYPUR then S1OP := XFMULT_S
else if TYP = TYPUQ then S1OP := XFMULT_D
else ASSERTFAIL('UMPY 005');
ALLOC_AND_EMIT_TOP (DEST, S1OP, OPND2, OPND2,
IS_DOUBLE[TYP],IS_DOUBLE[TYP], IS_DOUBLE[TYP], TOP);
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP,CODESTART,TYP,DEST);
end (*not constant*);
end;
end (*with STK[TOP] do*);
end (*case OPC of*)
end (*ARITH_3_OPS*);
(*** ANI_CLASS: ARITH_4_OPS UDIV UDMD UMOD ***)
(**)
procedure ARITH_4_OPS;
begin
case OPC of (*UDIV, UDMD, UMOD*)
UDIV, UDMD, UMOD : (* als/peg 03jul79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE <> STK[TOP-1].DTYPE then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
if IS_INTEGER[TYP] then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP) then
begin
if RESDBL then ERROR(WNOT_IMPLEMENTED);
if STK[TOP].FPA.MEMADR.DSPLMT = 0 then
ERROR(WINTEGER_CONSTANT_DIV_MOD_BY_ZERO)
else if OPC = UDMD then
begin
STK[TMPD1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT div STK[TOP].FPA.MEMADR.DSPLMT;
STK[TOP].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT mod STK[TOP].FPA.MEMADR.DSPLMT;
STK[TOP-1].FPA.MEMADR.DSPLMT := STK[TMPD1].FPA.MEMADR.DSPLMT;
end
else
begin
if OPC = UDIV then STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT div STK[TOP].FPA.MEMADR.DSPLMT
else STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT mod STK[TOP].FPA.MEMADR.DSPLMT;
POPTOP
end
end
else (*not both constants*)
begin
if OPC = UDMD then (* peg 03jul79...*)
begin
if RESDBL then
begin
ERROR(WNOT_IMPLEMENTED);
% S1OP := XDIV_D;
FINDRGBLOCK(4);
DEST1 := NXTRG;
DEST2 := NXTRG + 2;
FREERG_S(DEST1);
ALLOCRP(DEST1);
ALLOCRP(DEST2); \(* als/peg 01aug79 *)
end
else
begin
S1OP := XDIV_S;
FINDRP;
DEST1 := NXTRG;
DEST2 := NXTRG + 1;
FREERG_S(DEST1);
ALLOCRG(DEST1);
ALLOCRG(DEST2);
end;
REG_OPERAND(OPNDR1, DEST1);
REG_OPERAND(OPNDR2, DEST2);
GET_OPERAND(OPND1, TOP-1);
GET_OPERAND(OPND2, TOP);
EMITXOP(MOV_X_X[RESTYPE], OPNDR1, OPND1);
EMITTOP(S1OP, 0, OPNDR1, OPND2);
FREEREGSBUTTHESE(TOP-1, [DEST1, DEST2]);
FREEREGSBUTTHESE(TOP, [DEST1, DEST2]);
REG_DATUM(TOP-1, RESCODESTART, RESTYPE, DEST1);
REG_DATUM(TOP, RESCODESTART, RESTYPE, DEST2);
end (*...peg 03jul79 *)
else
begin
if OPC = UDIV then
if RESDBL then S1OP := XQUO_D
else S1OP := XQUO_S
else (*OPC = UREM*)
if RESDBL then S1OP := XREM_D
else S1OP := XREM_S;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST,S1OP,OPND1,OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP, RESCODESTART, RESTYPE, DEST)
end
end (*not both constants*)
end (*IS_INTEGER, UMOD, UDMD*) else
if ((IS_REAL[TYP]) and (OPC = UDIV)) then
begin
RESCODESTART := STK[TOP-1].CODESTART;
RESTYPE := STK[TOP-1].DTYPE;
RESDBL := IS_DOUBLE[RESTYPE];
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
if not (RESTYPE = TYPUR) then ASSERTFAIL('ARITH_4 001');
begin
if STK[TOP].RCNST = 0 then
ERROR(WREAL_CONSTANT_DIVISION_BY_ZERO)
else STK[TOP-1].RCNST := STK[TOP-1].RCNST / STK[TOP].RCNST
end;
POPTOP
end
else (*not both constants*)
begin
S1OP := REAL_ARITH_OP[S1SIZE[RESTYPE],OPC];
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
ALLOC_AND_EMIT_TOP(DEST, S1OP, OPND1, OPND2,
RESDBL, RESDBL, RESDBL, TOP-1);
FREEREGSBUTTHESE(TOP,[DEST]);
POPTOP;
FREEREGSBUTTHESE(TOP,[DEST]);
REG_DATUM(TOP,RESCODESTART,RESTYPE,DEST)
end (*not both constants*)
end (*IS_REAL*)
else ERROR(WARITH_ON_WRONG_DT);
end (*UDIV,UDMD,UMOD*);
end (*case OPC of*)
end (*ARITH_4_OPS*);
(*** ANI_CLASS: COMPARE_SETS REL_OPS UEQU UGEQ UGRT ULEQ ULES UNEQ UIEQU UIGEQ UIGRT UILEQ UILES UINEQ ***)
(**)
procedure COMPARE_SETS; (*peg 03jul79...*)
(*Do the comparisons UEQU, UNEQ, UGEQ, and ULEQ for TYPUS operands.
GEQ is 'optimized' to an LEQ with the operands reversed
(GEQ and LEQ are the set inclusion operators; LEQ is thus
implemented as an AND RSET,SET1,SET2 followed by
EQU BOOL,RSET,SET2).*)
var BOOL : boolean;
begin
if (STK[TOP-1].DTYPE <> TYPUS) or (STK[TOP].DTYPE <> TYPUS) then
ERROR (WCOMPARE_ILLEGAL)
else if not (OPC in [UEQU, UNEQ, UGEQ, ULEQ]) then
ERROR (WWRONG_COMPARE)
else
begin (*setch...*)
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP)
and ((OPC = UEQU) or (OPC = UNEQ)) then
begin
if OPC = UEQU then
BOOL := STK[TOP-1].SCNST = STK[TOP].SCNST
else if OPC = UNEQ then
BOOL := STK[TOP-1].SCNST <> STK[TOP].SCNST
else if not (false) then ASSERTFAIL('COMPARE_S001');
POPTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
DTYPE := TYPUB;
BREPRES := BINTVAL;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := ord(BOOL);
end (*with STK[TOP] do*);
end (*if constants*)
else
begin (*not constant*)
LOADSTACKEXCEPT(TOP-1, TOP);
RESCODESTART := STK[TOP-1].CODESTART;
TMPJUMPLIST := EMPTYJUMPLIST;
if OPC = UGEQ then
begin
XCHANGE_STKENTS(TOP, TOP-1);
OPC := ULEQ;
end;
if OPC = ULEQ then
begin
FINDRGBLOCK(NUMOFSETPARTS*2);
DEST := NXTRG;
for I := 0 to (1 + SETPART_MAX*2) do
DESTREGS := DESTREGS + [DEST + I];
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
ALLOCRP(S1RTB);
for INDEX := 0 to SETPART_MAX do
begin
WHICHPART := INDEX;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
EMITTOP(XAND_D, 3, OPND1, OPND2); (*Result ==> RTB*)
REG_OPERAND(OPNDR, DEST + INDEX*2);
EMITXOP(XMOVMS_2, OPNDR, OPNDRTB);
end;
WHICHPART := 0;
FREERG_S(S1RTB);
FREEREGSBUTTHESE(TOP-1,DESTREGS);
REG_DATUM(TOP-1, STK[TOP-1].CODESTART, TYPUS, DEST);
end (*if OPC = ULEQ*);
if not RISFREE[S1RTB] and (RTBUSER < TOP-1) then
MOVE_AND_FREE_RTB;
for INDEX := 0 to SETPART_MAX do
begin
WHICHPART := INDEX;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_EQL_D, 0, OPND1, OPND2, nil);
JUMPLOC := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
if INDEX < SETPART_MAX then
AP_JUMP_TO_JUMPLIST(TMPJUMPLIST, JUMPLOC);
FIXSOP (SKIPLOC, NEWINSTREC);
end;
WHICHPART := 0;
FREEDATUMREGS(TOP-1);
FREEDATUMREGS(TOP);
POPTOP;
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := RESCODESTART;
DTYPE := TYPUB;
BREPRES := BJUMP;
NVPAS := 1; (*to make it not look
like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
if OPC = UNEQ then
begin
BFALSELIST := EMPTYJUMPLIST;
BTRUELIST := TMPJUMPLIST;
BJUMPON := true;
end
else (*OPC in [UEQU, ULEQ, UGEQ]*)
begin
BFALSELIST := TMPJUMPLIST;
BTRUELIST := EMPTYJUMPLIST;
BJUMPON := false;
end;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[TOP] do*);
end (*not constant*)
end (*...setch*)
end (*COMPARE_SETS*); (*...peg 15MAY79*)
procedure REL_OPS;
begin
case OPC of
UEQU, UNEQ, UGEQ, UGRT, ULEQ, ULES, (* als/peg 03jul79 *)
UIEQU, UINEQ, UIGEQ, UIGRT, UILEQ, UILES :
begin
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if (OPC = UIEQU) or (OPC = UINEQ) or (OPC = UIGEQ)
or (OPC = UIGRT) or (OPC = UILEQ) or (OPC = UILES) then
begin
for STE := TOP-1 to TOP do
with STK[STE] do
begin
INC_INDIRECTION(STE, IND1);
DTYPE := TYP;
DLENGTH := I1;
end (*with STK[STE] do*);
case OPC of
UIEQU : OPC := UEQU;
UINEQ : OPC := UNEQ;
UIGEQ : OPC := UGEQ;
UIGRT : OPC := UGRT;
UILEQ : OPC := ULEQ;
UILES : OPC := ULES;
end (*case*)
end (*UIEQU...UILES*);
if TYP = TYPUS then COMPARE_SETS
else
begin (*TYP <> TYPUS*)
if TYP <> TYPUM then
begin
if TYP in [TYPUJ, TYPUL] then
begin
COERCE_INT_DATUM(TOP-1);
COERCE_INT_DATUM(TOP);
end;
RESTYPE := COMPARE_COERCE_TYPE
[STK[TOP-1].DTYPE, STK[TOP].DTYPE];
if RESTYPE = ILLCOMP then
ERROR (WCOMPARE_ILLEGAL)
else if RESTYPE <> TYP then
ERROR (WWRONG_COMPARE);
RESCODESTART := STK[TOP-1].CODESTART;
COERCE_DATUM (TOP-1, RESTYPE);
COERCE_DATUM (TOP, RESTYPE);
if (RESTYPE in [TYPUA, TYPUI, TYPUJ, TYPUK, TYPUL]) and
(STK[TOP-1].FINALIND=IND0) and (STK[TOP].FINALIND=IND0) then
begin (*Bring constant parts to one side.*)
if not ((STK[TOP-1].FPA.WHICH = MEM) and
(STK[TOP].FPA.WHICH = MEM)) then
ASSERTFAIL('REL_OPS 001');
STK[TOP].FPA.MEMADR.DSPLMT :=
STK[TOP].FPA.MEMADR.DSPLMT - STK[TOP-1].FPA.MEMADR.DSPLMT;
STK[TOP-1].FPA.MEMADR.DSPLMT := 0;
end (*Bring constant parts to one side.*);
if RESTYPE = TYPUB then
begin
if STK[TOP-1].BREPRES = BJUMP then
BJUMP_TO_BINTVAL (TOP-1);
if STK[TOP].BREPRES = BJUMP then
BJUMP_TO_BINTVAL (TOP);
(*Note : <=,>=,<,> could be optimized as and, or are.*)
end;
S1OP := COMPARE_OP[S1SIZE[RESTYPE], OPC];
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
LOADSTACKEXCEPT (TOP-1, TOP);
if not RISFREE[S1RTB] and (RTBUSER < TOP-1) then
MOVE_AND_FREE_RTB;
FREEDATUMREGS (TOP);
POPTOP;
FREEDATUMREGS (TOP);
end (*TYP<>TYPUM*)
else
begin (*TYP = TYPUM*)
if not(STK[TOP-1].DTYPE in [TYPUA, TYPUM]) or
not(STK[TOP].DTYPE in [TYPUA, TYPUM]) then
ERROR (WCOMPM_NEEDS_ADDR);
(* make sure the zero and CPLPL global are free (to prevent errors) *)
ALLOCGBL (S1GBLZ);
OP1GBL := S1GCPLPL;
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
OP1GBL := succ(OP1GBL);
ALLOCGBL (OP1GBL);
(* initialize the global zero *)
OP1GBL := S1GBLZ;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, ZERO_OP);
(* initialize the CPLPL block-descriptor *)
OP1GBL := S1GCPLPL;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
IMM_OPERAND (OPND2, S1GBLZ*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, OPND2);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
MOVE_QUANTITY (OPND1, TOP-1);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
IMM_OPERAND (OPND2, I1);
EMITXOP (XMOV_S_S, OPND1, OPND2);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
MOVE_QUANTITY (OPND1, TOP);
OP1GBL := succ(OP1GBL);
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
IMM_OPERAND (OPND2, I1);
EMITXOP (XMOV_S_S, OPND1, OPND2);
(* emit the BLKCMP and subsequent flag test *)
ADDR_OPERAND (OPND2, S1GCPLPL*WORDUNITS); (*LCW*)
FREEDATUMREGS(TOP); (*EJG 16JAN79*)
FREEDATUMREGS(TOP-1); (*EJG 16JAN79*)
FINDRG;
OP1RG := NXTRG;
REG_OPERAND (OPND1, OP1RG);
EMITXOP (BLKCMP_X_Q[OPC], OPND1, OPND2);
DEST := OP1RG;
LOADSTACKEXCEPT (TOP-1, TOP);
POPTOP;
REG_OPERAND (OPND1, DEST);
IMM_OPERAND (OPND2, S1TRUEFLAG);
S1OP := XSKP_EQL_S;
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
FREERG_S (DEST);
(* free the global zero and CPLPL global *)
FREEGBL_S (S1GBLZ);
OP1GBL := S1GCPLPL;
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
OP1GBL := succ(OP1GBL);
FREEGBL_S (OP1GBL);
end (*TYPUM*);
SKIPLOC := NEWINSTREC;
EMITSOP (S1OP, 0, OPND1, OPND2, nil);
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
FIXSOP (SKIPLOC, NEWINSTREC);
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := RESCODESTART;
DTYPE := TYPUB;
NVPAS := 1; (*make it not look like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BREPRES := BJUMP;
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := false;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[TOP] do*);
end (*TYP <> TYPUS*)
end (*UEQU,...,UILES*);
end (*case OPC of*)
end (*REL_OPS*);
(*** ANI_CLASS: BOOL_OPS UAND UIOR UXOR UNOT UODD ***)
(**)
procedure BOOL_OPS;
begin
case OPC of
UAND, UIOR, UXOR : (* als/peg 03jul79 *)
begin
if STK[TOP].DTYPE <> TYP then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE <> STK[TOP-1].DTYPE then
ERROR(WBINARY_OPND_TYPE_CONFLICT);
if TYP <> TYPUB then ERROR (WANDOR_NEEDS_BOOLEAN);
if IS_CONSTANT(TOP) and IS_CONSTANT(TOP-1) then
begin
case OPC of
UAND :
STK[TOP-1].FPA.MEMADR.DSPLMT :=
ord((STK[TOP-1].FPA.MEMADR.DSPLMT = 1)
and (STK[TOP].FPA.MEMADR.DSPLMT = 1));
UIOR :
STK[TOP-1].FPA.MEMADR.DSPLMT :=
ord((STK[TOP-1].FPA.MEMADR.DSPLMT = 1)
or (STK[TOP].FPA.MEMADR.DSPLMT = 1));
UXOR :
STK[TOP-1].FPA.MEMADR.DSPLMT :=
ord( ((STK[TOP-1].FPA.MEMADR.DSPLMT = 1)
or (STK[TOP].FPA.MEMADR.DSPLMT = 1))
and not((STK[TOP-1].FPA.MEMADR.DSPLMT = 1)
and (STK[TOP].FPA.MEMADR.DSPLMT = 1)) );
end (*case*);
POPTOP;
end (*constant bintvals*)
else
begin (*non-constant bintvals*)
if STK[TOP-1].BREPRES = BJUMP then BJUMP_TO_BINTVAL(TOP-1);
if STK[TOP].BREPRES = BJUMP then BJUMP_TO_BINTVAL(TOP);
(* Eliminate codeforks.*)
RESCODESTART := STK[TOP-1].CODESTART;
if OPC = UAND then S1OP := XAND_Q
else if OPC = UIOR then S1OP := XOR_Q
else S1OP := XXOR_Q;
GET_OPERAND (OPND1, TOP-1);
GET_OPERAND (OPND2, TOP);
ALLOC_AND_EMIT_TOP (DEST, S1OP, OPND1, OPND2,
false, false, false, TOP-1);
FREEREGSBUTTHESE (TOP, [DEST]);
POPTOP;
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, RESCODESTART, TYPUB, DEST);
STK[TOP].BREPRES := BINTVAL;
end (*non-constant bintvals*);
end (*UAND, UIOR, UXOR*);
UNOT : (* als/peg 03jul79 *)
with STK[TOP] do
begin
if DTYPE <> TYPUB then
ERROR (WNOT_NEEDS_BOOLEAN);
RESCODESTART := CODESTART;
if BREPRES = BJUMP then
begin
TMPJUMPLIST := BTRUELIST;
BTRUELIST := BFALSELIST;
BFALSELIST := TMPJUMPLIST;
BJUMPON := not BJUMPON;
end (*BJUMP*)
else
begin (*BINTVAL*)
if IS_CONSTANT(TOP) then
FPA.MEMADR.DSPLMT := 1 - FPA.MEMADR.DSPLMT
else
begin (*non-constant bintval*)
GET_OPERAND (OPND1, TOP);
IMM_OPERAND (OPND2, 1);
ALLOC_AND_EMIT_TOP (DEST, XXOR_Q, OPND1, OPND2,
false, false, false, TOP);
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, CODESTART, TYPUB, DEST);
BREPRES := BINTVAL;
end (*non-constant bintval*);
end (*BINTVAL*);
end (*UNOT*);
UODD : (* als/peg 03jul79 *)
with STK[TOP] do
begin
if not IS_INTEGER[DTYPE] then
ERROR(WODD_REQUIRES_AN_INTEGER);
if IS_CONSTANT(TOP) then
begin
DTYPE := TYPUB;
BREPRES := BINTVAL;
FPA.MEMADR.DSPLMT := ord(odd(FPA.MEMADR.DSPLMT))
end
else
begin (*not constant*)
RESCODESTART := CODESTART;
GET_OPERAND(OPND1,TOP);
IMM_OPERAND(OPND2,1);
LOADSTACKEXCEPT(TOP, TOP);
if not RISFREE[S1RTB] and (RTBUSER <> TOP) then
MOVE_AND_FREE_RTB;
FREEDATUMREGS(TOP);
SKIPLOC := NEWINSTREC;
EMITSOP(SKP_NON_X[DTYPE],0,OPND1,OPND2,nil);
EMITJOP(XJMPA,0,UNUSED_OP,ZERO_OP,nil);
FIXSOP(SKIPLOC,NEWINSTREC);
STK[TOP] := ZERODATUM;
CODESTART := RESCODESTART;
DTYPE := TYPUB;
BREPRES := BJUMP;
NVPAS := 1; (*To make it not look like a constant.
Hopefully not needed.*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := true;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*not constant*)
end (*UODD*);
end (*case OPC of*)
end (*BOOL_OPS*);
(*** ANI_CLASS: SET_OPS UDIF UINT UUNI UINN USGS UADJ UMUS ***)
(**)
procedure SET_OPS;
begin
case OPC of
UDIF, UINT, UUNI : (* als/peg 05jul79 *)
begin
if (STK[TOP-1].DTYPE <> TYPUS) or (STK[TOP].DTYPE <> TYPUS) then
ERROR(WSET_OPERATION_ON_NONSET_TYPES)
else
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP) then
begin
if OPC = UDIF then
(*setch*) SET_DIF(STK[TOP-1].SCNST, STK[TOP-1].SCNST, STK[TOP].SCNST)
else if OPC = UINT then
(*setch*) SET_INT(STK[TOP-1].SCNST, STK[TOP-1].SCNST, STK[TOP].SCNST)
else if OPC = UUNI then
(*setch*) SET_UNI(STK[TOP-1].SCNST, STK[TOP-1].SCNST, STK[TOP].SCNST)
else if not (false) then ASSERTFAIL('UDIF,UINT001');
POPTOP
end
else (*not both constants*)
begin
if OPC = UDIF then S1OP := XAND_TC_D
else if OPC = UINT then S1OP := XAND_D
else if OPC = UUNI then S1OP := XOR_D
else if not (false) then ASSERTFAIL('UDIF,UINT002');
FINDRGBLOCK(NUMOFSETPARTS*2); (*setch...*)
DEST := NXTRG;
for I := 0 to (1 + SETPART_MAX*2) do
DESTREGS := DESTREGS + [DEST + I];
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
ALLOCRP(S1RTB);
for INDEX := 0 to SETPART_MAX do
begin
WHICHPART := INDEX;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
EMITTOP(S1OP, 3, OPND1, OPND2); (*Result ==> RTB*)
REG_OPERAND(OPNDR, DEST + INDEX*2);
EMITXOP(XMOVMS_2, OPNDR, OPNDRTB);
end;
WHICHPART := 0;
FREERG_S(S1RTB);
FREEREGSBUTTHESE(TOP-1,DESTREGS);
FREEREGSBUTTHESE(TOP,DESTREGS);
REG_DATUM(TOP-1, STK[TOP].CODESTART, TYPUS, DEST);
POPTOP; (*...setch*)
end (*not both constants*)
end (*UDIF, UINT, UUNI*);
USGS, UINN : (* als/peg 05jul79 *)
begin
if OPC = USGS then STE := TOP else STE := TOP-1;
with STK[STE] do
begin
if not IS_INTEGER[DTYPE] and not (DTYPE in [TYPUB,TYPUC]) then
ERROR(WSGS_OR_INN_REQUIRES_INT_CHAR_OR_BOOLEAN);
if DTYPE in [TYPUB,TYPUC] then
begin
if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
BJUMP_TO_BINTVAL(STE);
DTYPE := TYPUJ
end;
if IS_CONSTANT(STE) then
begin
if DTYPE in [TYPUI, TYPUK] then ERROR(WNOT_IMPLEMENTED);
if (FPA.MEMADR.DSPLMT < 0) or (FPA.MEMADR.DSPLMT > SET_MAX) then
ERROR(WCONST_OUT_OF_RANGE_FOR_SET);
DTYPE := TYPUS;
SCNST := NULL_SET; (*setch*)
BUILD_SET(SCNST, FPA.MEMADR.DSPLMT); (*setch*)
FPA := ZEROFPA;
end
else
begin (*not constant*)
if DTYPE in [TYPUI, TYPUK] then ERROR(WNOT_IMPLEMENTED);
FINDRG; OPRRG := NXTRG; (*setch...*)
REG_OPERAND(OPNDR,OPRRG);
GET_OPERAND(OPND2,STE);
EMITXOP(XMOV_S_S, OPNDR, OPND2);
FREEREGSBUTTHESE(STE, [OPRRG]);
FINDRGBLOCK(NUMOFSETPARTS*2);
DEST := NXTRG;
for INDEX := SETPART_MAX downto 0 do
begin
IMM_OPERAND(OPND2,1);
REG_OPERAND(OPND1, DEST + INDEX*2);
EMITXOP(XMOV_D_S,OPND1,OPND2);
EMITTOP(XSHF_LF_D, 0, OPND1, OPNDR);
if INDEX > 0 then
begin
IMM_OPERAND(OPND2, SET_SIZE div NUMOFSETPARTS);
EMITTOP(XSUB_S, 0, OPNDR, OPND2);
end;
end;
REG_DATUM(STE, CODESTART, TYPUS, DEST);
FREERG_S(OPRRG); (*...setch*)
end (*not constant*)
end (*with STK[STE] do*);
if OPC = UINN then
begin
if STK[TOP].DTYPE <> TYPUS then
ERROR(WINN_REQUIRES_SET_ON_TOP_OF_STACK);
if IS_CONSTANT(TOP-1) and IS_CONSTANT(TOP) then
begin
with STK[TOP-1] do
begin
DTYPE := TYPUB;
BREPRES := BINTVAL;
SET_INT(SCNST, SCNST, STK[TOP].SCNST); (*setch...*)
FPA.MEMADR.DSPLMT := ord(SCNST <> NULL_SET);
SCNST := NULL_SET; (*...setch*)
end;
POPTOP;
end
else
begin (*not constants*)
LOADSTACKEXCEPT(TOP-1, TOP);
if not RISFREE[S1RTB] and (RTBUSER < TOP-1) then
MOVE_AND_FREE_RTB;
RESCODESTART := STK[TOP-1].CODESTART;
TMPJUMPLIST := EMPTYJUMPLIST; (*setch...*)
for INDEX := 0 to SETPART_MAX do
begin
WHICHPART := INDEX;
GET_OPERAND(OPND1,TOP-1);
GET_OPERAND(OPND2,TOP);
SKIPLOC := NEWINSTREC;
EMITSOP (XSKP_NON_D, 0, OPND1, OPND2, nil);
JUMPLOC := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
if INDEX < SETPART_MAX then
AP_JUMP_TO_JUMPLIST(TMPJUMPLIST, JUMPLOC);
FIXSOP (SKIPLOC, NEWINSTREC);
end;
WHICHPART := 0;
FREEDATUMREGS(TOP-1);
FREEDATUMREGS(TOP); (*...setch*)
POPTOP;
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := RESCODESTART;
DTYPE := TYPUB;
BREPRES := BJUMP;
NVPAS := 1; (*to make it not look
like a constant. Not needed?*)
FINDRG;
VPA1.VPA.WHICH := RGS;
VPA1.VPA.RGADR := NXTRG;
(*where it will go if it becomes bintval*)
BTRUELIST := TMPJUMPLIST; (*setch*)
BFALSELIST := EMPTYJUMPLIST;
BJUMPON := true;
BFALLTHRUSKIPLOC := SKIPLOC;
end (*with STK[TOP] do*);
end (*not constants*);
end (*if OPC = UINN*);
end (*USGS, UINN*);
UADJ : (**** Write UADJ, UMUS.*)
begin
ERROR (WNOT_IMPLEMENTED);
end (*UADJ*);
UMUS :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UMUS*);
end (*case OPC of*)
end (*SET_OPS*);
(*** ANI_CLASS: LOAD1_STORE_OPS ULCA ULDA ULDC ULOD ULDP UILOD UPLOD ***)
(**)
procedure LOAD1_STORE_OPS;
begin
case OPC of
ULCA :
begin
if not (TYP in [TYPUB, TYPUC, TYPUI, TYPUJ, TYPUK, TYPUL,
TYPUM, TYPUQ, TYPUR, TYPUS]) then ERROR(WWRONG_INSTR_DATATYPE);
if TYP <> TYPUM then ERROR(WNOT_IMPLEMENTED);
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYPUM;
DLENGTH := I1;
MTYPE := M_SPACE;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := NXTSTRDISP;
STARTBIT := NXTSTRDISP mod WORDCHARS * CHARBITS;
for I := 1 to SLGTH do
begin
if STARTBIT = 0 then
EMIT_ZEROS1WORD (STRINGAREA, STRINGAR_CPTR);
PUTFIELD (STRINGAR_CPTR↑.CODEWORD, STARTBIT,
CHARBITS, ord(SVAL[I])-CHARDIF ); (*CHARDIF*)
STARTBIT := (STARTBIT + CHARBITS) mod WORDBITS;
end;
NXTSTRDISP := NXTSTRDISP + SLGTH;
end (*with STK[TOP] do*);
end (*PLCA*);
ULDA : (* peg 03jul79 *)
begin
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYPUA;
DLENGTH := WORDUNITS; (*pn*)
MTYPE := MTYP;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := BLOCKTABLE[I1];
FPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (FPA, MTYP);
end (*with STK[TOP] do*);
end (*ULDA*);
ULDC : (* peg 03jul79 *)
begin
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYP;
DLENGTH := I1;
MTYPE := DEFAULTMTYPE;
case TYP of
TYPUB :
begin
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := I2;
BREPRES := BINTVAL;
end;
TYPUC :
begin
if SLGTH <> 1 then ASSERTFAIL('ULDC 001');
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := ord(SVAL[1]) - CHARDIF;
end;
TYPUJ, TYPUL :
begin
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := I2;
end;
TYPUR : RCNST := R1;
TYPUN : (*null case*);
TYPUS : SCNST := P1;
TYPUA, TYPUP :
ERROR (WINVAL_TYP_ON_LDC);
TYPUI, TYPUK, TYPUM, TYPUQ :
ERROR (WNOT_IMPLEMENTED);
end (*case TYP of*);
end (*with STK[TOP] do*);
end (*LDC*);
ULOD : (* peg 03jul79 *)
begin
if (I2 div QWBITS) mod ALIGNBNDRY[TYP] <> 0 then
ERROR (WALIGNMENT_ERROR);
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYP;
DLENGTH := I3;
MTYPE := MTYP;
NVPAS := 1;
VPA1.VPAIND := IND1;
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := BLOCKTABLE[I1];
VPA1.VPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (VPA1.VPA, MTYP);
if TYP = TYPUB then BREPRES := BINTVAL;
end (*with STK[TOP] do*);
end (*ULOD*);
ULDP :
begin
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYPUJ;
DLENGTH := 36;
MTYPE := DEFAULTMTYPE;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := 0;
FPA.MEMADR.DSPLMT := I1;
end;
end (*ULDP*);
UILOD : (* als/peg 03jul79 *)
begin
with STK[TOP] do
begin
if DTYPE <> TYPUA then
if DTYPE = TYPUN then ERROR (WNULLREF)
else if DTYPE = TYPUM then ERROR (WLOADING_STRING)
else ERROR (WNOT_AN_ADDR);
if TYP = TYPUE then
begin
TYP := TYPUJ;
I2 := 36;
end;
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if FPA.WHICH = RGS then
ERROR (WINDEXING_IN_PARMS);
if I1 = 0 then MAXFINALIND := IND1 else MAXFINALIND := IND0;
FPA.MEMADR.DSPLMT := FPA.MEMADR.DSPLMT + I1;
INC_INDIRECTION(TOP, MAXFINALIND);
DTYPE := TYP;
DLENGTH := I2;
end (*with STK[TOP] do*);
end (*UILOD*);
UPLOD : (* als/peg 18jul79 *)
with CURPROCSPEC do
begin
if PROCTYPE <> TYP then
ERROR (WENT_AND_PLOD_INCONSISTENT);
if TYP <> TYPUP then
begin (*copy function result to RTB*)
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYP;
DLENGTH := I3;
MTYPE := MTYP;
NVPAS := 1;
VPA1.VPAIND := IND1;
VPA1.VPA.WHICH := MEM;
VPA1.VPA.MEMADR.LVL := BLOCKTABLE[I1];
VPA1.VPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (VPA1.VPA, MTYP);
if TYP = TYPUB then BREPRES := BINTVAL;
end (*with STK[TOP] do*);
MOVE_QUANTITY(OPNDRTB, TOP);
end (*copy function result*);
end (*UPLOD*);
end (*case OPC of*)
end (*LOAD1_STORE_OPS*);
(*** ANI_CLASS: LOAD2_STORE_OPS USTR UNSTR UISTR UINST UPSTR UMOV ***)
(**)
procedure LOAD2_STORE_OPS;
begin
case OPC of
USTR, UNSTR : (* als/peg 03jul79 *)
begin
if (I2 div QWBITS) mod ALIGNBNDRY[TYP] <> 0 then
ERROR (WALIGNMENT_ERROR);
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUE, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if TYP = TYPUE then (*pn*)
begin
TYP := TYPUJ;
I3 := 36;
end;
if not( (STK[TOP].DTYPE = TYP) or
((TYP = TYPUA) and (STK[TOP].DTYPE = TYPUN)) ) then
ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if TYP in [TYPUJ, TYPUL] then
begin
CVT_INT_DATUM(TOP);
TYP := LENGTH_TO_INTOPNDTYPE(I3);
end;
STK[TMPD1] := ZERODATUM;
with STK[TMPD1] do
begin
CODESTART := STK[TOP].CODESTART;
DTYPE := TYPUA;
DLENGTH := I3;
MTYPE := MTYP;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := BLOCKTABLE[I1];
FPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (FPA, MTYP);
end;
for STE := BOT to TOP do
LOADSTKENTRY(STE); (*Prevent side effects*)
STORE (TMPD1, TOP);
if OPC = USTR then
begin
FREEDATUMREGS (TOP);
POPTOP;
end;
(* FREEDATUMREGS (TMPD1);*)(*This should be superfluous.*)
end (*USTR, UNSTR*);
UISTR, UINST : (* als/peg 06jul79 *)
begin (* Alignment??*)
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if not( (STK[TOP].DTYPE = TYP) or
((TYP = TYPUA) and (STK[TOP].DTYPE = TYPUN)) ) then
ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP-1].DTYPE <> TYPUA then
ERROR(WISTR_INST_NEEDS_ADDRS);
INCREMENT_DATUM(TOP-1, I1);
if TYP in [TYPUJ, TYPUL] then
begin
CVT_INT_DATUM(TOP);
TYP := LENGTH_TO_INTOPNDTYPE(I2);
end;
for STE := BOT to TOP do
LOADSTKENTRY(STE); (*Prevent side effects*)
STORE(TOP-1, TOP);
FREEDATUMREGS(TOP-1);
if OPC = UINST then
begin
STK[TOP-1] := STK[TOP];
STK[TOP-1].DLENGTH := I2;
end
else (*OPC = UISTR*)
begin
FREEDATUMREGS(TOP);
POPTOP;
end;
POPTOP;
end (*UISTR, UINST*);
UPSTR : (* als/peg 13jul79 *)
begin
PSTRCOUNT := PSTRCOUNT + 1;
PUSHTOP; STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYP;
DLENGTH := I3;
MTYPE := MTYP;
FPA.WHICH := MEM;
FPA.MEMADR.LVL := BLOCKTABLE[I1];
FPA.MEMADR.DSPLMT := I2;
TRANSLATE_LVLDSP (FPA, MTYP);
end (*with STK[TOP] do*);
if PSTRCOUNT = CURPROCSPEC.PARMS_POPPED then
with CURPROCSPEC do
begin
PWORD := 0;
EXCESS := 0;
for I := 1 to PARMS_POPPED do
begin
if STK[TOP].MTYPE = R_SPACE then
if IS_DOUBLE[STK[TOP].DTYPE] then
PWORD := PWORD + 2
else PWORD := PWORD + 1
else if STK[TOP].MTYPE = M_SPACE then
EXCESS := EXCESS + STK[TOP].DLENGTH div WORDBITS
else ERROR(WNOT_IMPLEMENTED);
POPTOP;
end (*for*);
REGPARMAREA := PWORD*WORDUNITS;
RESERVE_PARMREGS(PWORD);
if EXCESS > 0 then
(*There were so many parms that we passed some in the caller's
stackframe regs. Copy them into the parm save area where
they belong. The caller has passed the address of the begin-
ning of the parameter block in RTB -- peg 13jul79. *)
if EXCESS <= MAXMOVMS then (*emit a MOVMS instruction*)
begin
ALLOCRG(S1RTB);
OFFSET := -OFFSET_IN_VARS + DOUBLEWORDUNITS;
(****This allows for function result, and will
probably need to be changed for UPAS -- peg*)
REGDISP_OPERAND (OPND1, DISPLAY, OFFSET);
REGDISP_OPERAND (OPND2, S1RTB, 0);
EMITXOP(MOVMS_N[EXCESS], OPND1, OPND2);
FREERG_S(S1RTB);
end (*emit a MOVMS*)
(**** Note: this should probably use a loop of MOVMS instructions, as
does MOV (q.v., below); perhaps the code (including the BLKMOV code)
should be put into a procedure, as it is lengthy -- peg.*)
else (*emit a BLKMOV*)
begin
(*make sure that the global zero
and CPL are free (error if not)*)
ALLOCGBL (S1GBLZ);
ALLOCRG (S1RCPL);
ALLOCRG (succ(S1RCPL));
ALLOCRG (succ(succ(S1RCPL)));
(* initialize the global zero *)
OP1GBL := S1GBLZ;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, ZERO_OP);
(*initialize the CPL block descriptor*)
REG_OPERAND (OPNDR1, S1RCPL);
IMM_OPERAND (OPND2, S1GBLZ*WORDUNITS);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
(* set up the destination address and length *)
REG_OPERAND (OPNDR1, succ(S1RCPL));
REGDISP_OPERAND (OPND2, DISPLAY, -OFFSET_IN_VARS);
EMITXOP (XMOV_A, OPNDR1, OPND2);
REG_OPERAND (OPNDR1, succ(succ(S1RCPL)));
IMM_OPERAND (OPND2, EXCESS);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
(*emit the BLKMOV*)
ALLOCRG(S1RTB);
REG_OPERAND (OPNDR1, S1RCPL);
REG_OPERAND (OPNDR2, S1RTB);
INSTLOC := NEWINSTREC;
EMITXOP (XBLKMOV, OPNDR1, OPNDR2);
FREERG_S(S1RTB);
(*free the global zero and CPL registers*)
FREEGBL_S (S1GBLZ);
FREERG_S (S1RCPL);
FREERG_S (succ(S1RCPL));
FREERG_S (succ(succ(S1RCPL)));
end (*emit a BLKMOV*);
end (*with CURPROCSPEC*);
end (*UPSTR*);
UMOV :
begin
(* LCW 2AUG78
The strategy for UMOV is to do a BLKMOV if the transfer length is long
enough to justify the BLKMOV overhead, else to do a series of MOVMQs,
starting with the longest available MOVMQ and proceeding to the short
MOVMQs if necessary.
This procedure ignores the problem associated with having overlapping
source and destination where the source address is less than the
destination address. In that case, SOPA may destroy the source during
the MOV. However, if the source and destination overlap completely,
then SOPA will not destroy the source. Note that PASCAL and PCode do
not explicitly define the semantics of MOV when the source and
destination incompletely overlap.
*)
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if not (STK[TOP-1].DTYPE in [TYPUA,TYPUM]) or
not (STK[TOP].DTYPE in [TYPUA,TYPUM]) then
ERROR (WMOV_NEEDS_ADDRS);
if I1 mod QWBITS <> 0 then ERROR(WALIGNMENT_ERROR)
else I1 := I1 div QWBITS;
if I1 >= BLKMOV_THRESH then
begin (*generate BLKMOV*)
(*make sure that the global zero and CPL are free (error if not)*)
ALLOCGBL (S1GBLZ);
ALLOCRG (S1RCPL);
ALLOCRG (succ(S1RCPL));
ALLOCRG (succ(succ(S1RCPL)));
(* initialize the global zero *)
OP1GBL := S1GBLZ;
ADDR_OPERAND (OPND1, OP1GBL*WORDUNITS);
EMITXOP (XMOV_S_S, OPND1, ZERO_OP);
(*initialize the CPL block descriptor*)
REG_OPERAND (OPNDR1, S1RCPL);
IMM_OPERAND (OPND2, S1GBLZ*WORDUNITS);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
REG_OPERAND (OPNDR1, succ(S1RCPL));
MOVE_QUANTITY (OPNDR1, TOP-1);
REG_OPERAND (OPNDR1, succ(succ(S1RCPL)));
IMM_OPERAND (OPND2, I1);
EMITXOP (XMOV_S_S, OPNDR1, OPND2);
(*emit the BLKMOV*)
REG_OPERAND (OPNDR1, S1RCPL);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XBLKMOV, OPNDR1, OPND2);
(*free the global zero and CPL registers*)
FREEGBL_S (S1GBLZ);
FREERG_S (S1RCPL);
FREERG_S (succ(S1RCPL));
FREERG_S (succ(succ(S1RCPL)));
end (*generate BLKMOV*)
else
begin (*generate MOVMQ*)
XFER_CNT := I1;
while XFER_CNT >= 128 do
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XMOVMQ_128, OPND1, OPND2);
XFER_CNT := XFER_CNT - 128;
if XFER_CNT > 0 then
begin
INCREMENT_DATUM (TOP-1, 128);
INCREMENT_DATUM (TOP, 128);
end;
end;
if XFER_CNT >= 64 then
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XMOVMQ_64, OPND1, OPND2);
XFER_CNT := XFER_CNT - 64;
if XFER_CNT > 0 then
begin
INCREMENT_DATUM (TOP-1, 64);
INCREMENT_DATUM (TOP, 64);
end;
end;
if XFER_CNT >= 32 then
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (XMOVMQ_32, OPND1, OPND2);
XFER_CNT := XFER_CNT - 32;
if XFER_CNT > 0 then
begin
INCREMENT_DATUM (TOP-1, 32);
INCREMENT_DATUM (TOP, 32);
end;
end;
if XFER_CNT > 0 then
begin
GET_ADDRESS (OPND1, TOP-1);
GET_ADDRESS (OPND2, TOP);
EMITXOP (MOVMQ_N[XFER_CNT], OPND1, OPND2);
end;
end (*generate MOVMQ*);
FREEDATUMREGS (TOP);
POPTOP;
FREEDATUMREGS (TOP);
POPTOP;
end (*PMOV*);
end (*case OPC of*)
end (*LOAD2_STORE_OPS*);
(*** ANI_CLASS: FLOW_CONTROL_OPS UTJP UFJP UUJP UXJP UGOOB ULAB UCLAB ***)
(**)
procedure FLOW_CONTROL_OPS;
begin
case OPC of
UTJP, UFJP : (* peg 02jul79 *)
begin
if TOP <> BOT then
ERROR (WTJP_FJP_WITH_NONEMPTY_STACK);
LABNUM := LABELNUMBER(NAM1);
with STK[TOP] do
begin
if DTYPE <> TYPUB then
ERROR (WTJP_FJP_NEEDS_BOOLEAN);
if BREPRES = BINTVAL then
if IS_CONSTANT(TOP) then
if ((OPC = UTJP) and (FPA.MEMADR.DSPLMT = 1))
or ((OPC = UFJP) and (FPA.MEMADR.DSPLMT = 0)) then
begin (*jump always*)
JUMPLOC := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
JMP_TO_LABEL_RECORD_OR_FIX (JUMPLOC, LABNUM);
end
else if ((OPC = UTJP) and (FPA.MEMADR.DSPLMT = 0))
or ((OPC = UFJP) and (FPA.MEMADR.DSPLMT = 1)) then
(*never jump*)
else ASSERTFAIL('UTJP,UFJP001')
else
begin (*non-constant bintval*)
if OPC = UTJP then S1OP := XJMPZ_NEQ_Q
else S1OP := XJMPZ_EQL_Q;
GET_OPERAND (OPND1, TOP);
JUMPLOC := NEWINSTREC;
EMITJOP (S1OP, 0, OPND1, ZERO_OP, nil);
JMP_TO_LABEL_RECORD_OR_FIX (JUMPLOC, LABNUM);
end (*non-constant bintval*)
else
begin (*bjump representation*)
if (BJUMPON and (OPC = UFJP))
or ((not BJUMPON) and (OPC = UTJP)) then
begin
BFALLTHRUSKIPLOC↑.OPCODE := INVERSE_SKIP[BFALLTHRUSKIPLOC↑.OPCODE];(*DATASTRCH*)
BJUMPON := not BJUMPON;
end;
if OPC = UFJP then
PTR := BTRUELIST.FIRST
else PTR := BFALSELIST.FIRST;
while PTR <> nil do
begin
NEXT := PTR↑.DESTPTR; (*DATASTRCH*)
FIXJOP (PTR, NEWINSTREC);
PTR := NEXT;
end;
if OPC = UFJP then
PTR := BFALSELIST.FIRST
else PTR := BTRUELIST.FIRST;
while PTR <> nil do
begin
NEXT := PTR↑.DESTPTR; (*DATASTRCH*)
JMP_TO_LABEL_RECORD_OR_FIX (PTR, LABNUM);
PTR := NEXT;
end;
FALLTHRUJUMP := BFALLTHRUSKIPLOC↑.NEXTPTR; (*DATASTRCH*)
JMP_TO_LABEL_RECORD_OR_FIX (FALLTHRUJUMP, LABNUM);
end (*bjump representation*);
end (*with STK[TOP] do*);
FREEDATUMREGS (TOP);
POPTOP;
end (*UTJP, UFJP*);
UUJP : (* als/peg 28jun79 *)
begin
if TOP <> BOT-1 then
ERROR (WUJP_WITH_NONEMPTY_STACK);
JUMPLOC := NEWINSTREC;
PR_BIT := ord( JUMPTABLE_IN_PROGRESS );
EMITJOP (XJMPA, PR_BIT, UNUSED_OP, ZERO_OP, nil);
JMP_TO_LABEL_RECORD_OR_FIX (JUMPLOC, LABELNUMBER(NAM1));
end (*UUJP*);
UXJP : (* peg 05jul79 *)
begin
(*XJP compiles into
SKP if too small to A
SKP if not too big to B
A: JUMP to default
B: JUMP to wherever(index) *)
if TOP <> BOT then
ERROR (WXJP_WITHOUT_SINGLETON_STACK);
if not IS_INTEGER[TYP] then
ERROR (WWRONG_INSTR_DATATYPE);
if not (TYP = STK[TOP].DTYPE) then
ERROR (WINSTR_TYPE_NOT_DATUM_TYPE);
if TYP in [TYPUI, TYPUK] then
ERROR(WNOT_IMPLEMENTED);
LABNUM1 := LABELNUMBER(NAM1);
LABNUM2 := LABELNUMBER(NAM2);
if TYP in [TYPUJ, TYPUL] then CVT_INT_DATUM(TOP);
COERCE_DATUM (TOP, TYPUJ);
if IS_CONSTANT(TOP) then
begin
IMM_OPERAND (OPND, STK[TOP].FPA.MEMADR.DSPLMT);
XTNDED_REGDISP_OPERAND
(OPND1, S1RPC, I1 - STK[TOP].FPA.MEMADR.DSPLMT)
(*Looks funny but it is compatible with
the negate-and-shift fixup which
must be done in the case of a
variable index.*)
end
else
begin
GET_SHORT_OPERAND (OPND, TOP);
OPND1 := OPND;
OPND1.X := 1;
OPND1.XW.V := 1;
OPND1.XW.S := DALIGNSHIFT;
OPND1.XW.REG := S1RPC;
OPND.XW.DISP := -I1;
end;
IMM_OPERAND(OPND2, I1);
SKIPSMALL := NEWINSTREC;
EMITSOP (XSKP_LSS_S, 0, OPND, OPND2, nil);
IMM_OPERAND(OPND2, I2);
SKIPNOTBIG := NEWINSTREC;
EMITSOP (XSKP_LEQ_S, 0, OPND, OPND2, nil);
JUMPDEFAULT := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, ZERO_OP, nil);
JUMPINDEXED := NEWINSTREC;
EMITJOP (XJMPA, 0, UNUSED_OP, OPND1, nil);
FIXSOP (SKIPSMALL, JUMPDEFAULT);
FIXSOP (SKIPNOTBIG, JUMPINDEXED);
JMP_TO_LABEL_RECORD_OR_FIX (JUMPDEFAULT, LABNUM2);
ADD_INSTPTR_TO_OPND2FIXLIST (NEG_SHIFT_FIXLIST, JUMPINDEXED); (*DATASTRCH*)
(*All OPND2s on this fixup list will have the displacement
in the extended word negated and arithmetically shifted
to make it a doubleword index.*)
JMP_TO_TABLE_RECORD_OR_FIX (JUMPINDEXED, LABNUM1);
FREEDATUMREGS (TOP);
POPTOP;
end (*UXJP*);
UGOOB :
begin
(* NOTE: This instruction cuts back the RUNTIME stack, going back through
the DYNAMIC links to find the correct lexical level. We'll have to generate
an external fixup for the linker, since the destination has not been seen
yet and won't be during this segment -- peg.*)
ERROR (WNOT_IMPLEMENTED);
end (*UGOOB*);
ULAB, UCLAB : (* peg 02jul79 *)
(* Note: LAB operand, branch count, is in I1. If this value is 1 we might
rearrange the code, or perhaps the Optimizer should do it. ALS *)
begin
if TOP <> BOT - 1 then
ERROR(WSTACK_NON_EMPTY);
UPD_LBLTBL (LPTR, LABELNUMBER(NAM0), LINSTPTR); (*DATASTRCH*)
with LPTR↑ do
begin
if DEFINED then ERROR (WMULT_DEFINED_LAB);
DEFINED := true;
if OPC = ULAB then BRANCH_CNT := I1; (* peg 02jul79 *)
INSTPTR := NEWINSTREC; (*DATASTRCH*)
if JUMPTABLELABEL then JUMPTABLE_IN_PROGRESS := true;
PTR := JLIST.FIRST;
while PTR <> nil do
begin
NEXT := PTR↑.DESTPTR; (*DATASTRCH*)
FIXJOP (PTR, INSTPTR); (*DATASTRCH*)
PTR := NEXT
end;
JLIST := EMPTYJUMPLIST;
end (*with LPTR↑ do*);
%* if OPC = UCLAB then (*What is this garbage???! peg 25jul*)
begin
UPD_LBLTBL (LPTR, -1, LINTVAL); (* lower case boundary is always 0 *)
with LPTR↑ do
begin
DEFINED := true;
INTVAL := 0;
FIXOPND2 (CLIST.FIRST↑.OPND2IPTR, INTVAL); (*DATASTRCH*)
CLIST := EMPTYOPND2FIXLIST; (*DATASTRCH*)
end (*with LPTR↑ do*);
UPD_LBLTBL (LPTR, -2, LINTVAL); (* upper case boundary *)
with LPTR↑ do
begin
DEFINED := true;
INTVAL := I1-1;
FIXOPND2 (CLIST.FIRST↑.OPND2IPTR, INTVAL); (*DATASTRCH*)
CLIST := EMPTYOPND2FIXLIST;
end (*with LPTR↑ do*);
end; *\ (*...end garbage*)
end (*ULAB, UCLAB*);
end (*case OPC of*)
end (*FLOW_CONTROL_OPS*);
(*** ANI_CLASS: ENVIRONMENT_OPS UBGN UEND USTP UENT UBGNB UENDB ***)
(**)
procedure ENVIRONMENT_OPS;
begin
case OPC of
UBGN :
begin (* als/peg 05jul79 *)
CURPROG := NAM1;
end (*UBGN*);
USTP : (* als/peg 05jul79 *)
begin
if NAM1 <> CURPROG then
ERROR(WBGN_STP_NAME_MISMATCH);
end (*USTP*);
UEND : (* als/peg 05jul79 *)
begin
if NAM1 <> CURPROCXN then
ERROR(WENT_END_NAME_MISMATCH);
if PSTRCOUNT <> CURPROCSPEC.PARMS_POPPED then
ERROR(WENT_SPECIFIED_WRONG_PARMS);
if TOP > BOT - 1 then
while TOP >= BOT do POPTOP;
GEN_SEGMENT;
end (*UEND*);
UENT : (* als/peg 13jul79 *)
begin
CURPROCXN := NAM0;
CURLVL := I1;
CURPROC := NAM0.NAM;
INIT_SEGMENT;
PSTRCOUNT := 0; (* Set here to use as check in UPSTR and UEND. *)
if I1 <= 0 then
ERROR (WINVALID_LEVEL)
else if I1 > MAXLVLUSED then
begin
MAXLVLUSED := I1;
MINDSPS1REG := MAXDSPS1REG - (MAXLVLUSED-1);
CHECK_DSP_TMP_COLLISION
end;
DISPLAY := LVL_TO_S1REG[CURLVL];
if DISPLAY < MINDSPS1REG then ASSERTFAIL('UENT 001');
BLOCKTABLE[I2] := CURLVL;
with CURPROCSPEC do
begin
PROCTYPE := TYP;
PROCNAM := CURPROCXN;
PARMS_POPPED := I3;
if PARMS_POPPED = 0 then
RESERVE_PARMREGS(0);
RESULTS_PUSHED := I4;
REGPARMAREA := 0;
R_MEMORY_AREA := 0;
M_MEMORY_AREA := 0;
if not DEBUG then
begin
REG_OPERAND (OPNDR, DISPLAY);
if CURLVL = 1 then
XTNDED_REGDISP_OPERAND (OPND2, S1RSP, L1DISPLAY_OFFSET
(*+ eval save size by fixup*) )
else (*CURLVL > 1*)
XTNDED_REGDISP_OPERAND (OPND2, S1RSP, DISPLAY_OFFSET
(*+ eval save size by fixup*) );
INSTLOC := NEWINSTREC;
EMITXOP (XMOV_A, OPNDR, OPND2);
ADD_INSTPTR_TO_OPND2FIXLIST (EVALSAVE.FIXLIST, INSTLOC); (*DATASTRCH*)
if CURLVL = 1 then
XTNDED_IMM_OPERAND(OPND2, FILBUFAREASIZE)
else (*CURLVL > 1*)
XTNDED_IMM_OPERAND(OPND2, REGIMAGEAREASIZE);
INSTLOC := NEWINSTREC;
EMITXOP (XADJSP_UP, OPNDRSP, OPND2);
ADD_INSTPTR_TO_OPND2FIXLIST (EVALSAVE.FIXLIST, INSTLOC); (*DATASTRCH*)
ADD_INSTPTR_TO_OPND2FIXLIST (STACKFRAME.FIXLIST, INSTLOC); (*DATASTRCH*)
(**** Note: this will have to have the expr. temp. stack and large callee
parm. area sizes fixed up, too--peg*)
end
else (*DEBUG*)
begin (*allocate extra word for callee segment base save*)
REG_OPERAND (OPNDR, DISPLAY);
if CURLVL = 1 then
XTNDED_REGDISP_OPERAND (OPND2, S1RSP,
L1DISPLAY_OFFSET + WORDUNITS
(*+ eval save size by fixup*) )
else (*CURLVL > 1*)
XTNDED_REGDISP_OPERAND (OPND2, S1RSP,
DISPLAY_OFFSET + WORDUNITS
(*+ eval save size by fixup*) );
INSTLOC := NEWINSTREC;
EMITXOP (XMOV_A, OPNDR, OPND2);
ADD_INSTPTR_TO_OPND2FIXLIST (EVALSAVE.FIXLIST, INSTLOC); (*DATASTRCH*)
ADDR_OPERAND (OPND1, S1GSEGBASE*WORDUNITS);
if CURLVL = 1 then
XTNDED_IMM_OPERAND (OPND2, FILBUFAREASIZE + WORDUNITS)
else (*CURLVL > 1*)
XTNDED_IMM_OPERAND (OPND2, REGIMAGEAREASIZE + WORDUNITS);
INSTLOC := NEWINSTREC;
EMITXOP (XALLOC_1, OPND1, OPND2);
ADD_INSTPTR_TO_OPND2FIXLIST (EVALSAVE.FIXLIST, INSTLOC); (*DATASTRCH*)
ADD_INSTPTR_TO_OPND2FIXLIST (STACKFRAME.FIXLIST, INSTLOC); (*DATASTRCH*)
(**** And expr. temp. and parm. area lists???*)
XTNDED_REGDISP_OPERAND (OPND2, S1RPC, 0);
EMITXOP (XMOV_A, OPND1, OPND2);
(*OPND2 needs to be fixed up by subtracting this
instruction's displacement in the segment. The
code concretizer will do this automatically
because it normalizes *all* PC-relative addresses
to the beginning of the segment.*)
end (*allocate extra word*);
end (*with CURPROCSPEC...*);
end (*UENT*);
UBGNB : (* peg 09jul79 *)
begin
if CURFRAME >= MAXFRAME then
ERROR(W2_MANY_BGNBS);
PUSH_STKFRAME;
end (*UBGNB*);
UENDB : (* peg 09jul79 *)
begin
if CURFRAME <= MINFRAME then
ERROR(W2_MANY_ENDBS);
POP_STKFRAME;
end (*UENDB*);
end (*case OPC of*)
end (*ENVIRONMENT_OPS*);
(*** ANI_CLASS: CHECK_OPS UCHKL UCHKH UCHKT UCHKF UCHKN ***)
(**)
procedure CHECK_OPS;
begin
case OPC of
UCHKH, UCHKL : (* peg 07jul79 *)
(****Note: peephole optimizer may optimize the case where a CHKL
is followed immediately by a CHKH on the same item; it may have
to be done here because of literal table fixup problems. Also,
this routine needs to be modified when our error codes are
standardized -- peg 23sep79.*)
begin
if not (STK[TOP].DTYPE in
[TYPUA, TYPUC, TYPUI, TYPUJ, TYPUK, TYPUL, TYPUN, TYPUS]) then
ERROR(WCHECKING_INVALID_TYPE);
if not( (STK[TOP].DTYPE = TYP) or
((TYP = TYPUA) and (STK[TOP].DTYPE = TYPUN)) ) then
ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if TYP in [TYPUI, TYPUK, TYPUS] then ERROR(WNOT_IMPLEMENTED);
if TYP = TYPUC then
I1 := I1 + CHARDIF;
if IS_CONSTANT(TOP) then
begin
if ((OPC = UCHKH) and (STK[TOP].FPA.MEMADR.DSPLMT > I1))
or ((OPC = UCHKL) and (STK[TOP].FPA.MEMADR.DSPLMT < I1)) then
ERROR(WCHECKED_CONSTANT_OUT_OF_RANGE);
end
else (*not constant*)
begin
if OPC = UCHKH then
begin
LOWBOUND := MIN_ON_COMP_MACH + 1; (**** This is a kludge -- *)
HIGHBOUND := I1; (* als/peg 31jul79*)
end (*OPC = UCHKH*)
else (*OPC = UCHKL*)
begin
LOWBOUND := I1;
HIGHBOUND := MAX_ON_COMP_MACH;
end;
GET_OPERAND(OPND2, TOP);
XTNDED_REGDISP_OPERAND(OPND1, S1RPC, 0);
UPD_BOUNDTBL(OPND1.XW.DISP, LOWBOUND, HIGHBOUND, TYP);
OPND1.FIXUP := BOUNDFIX;
EMITXOP(BTRP_B_X[TYP],OPND1,OPND2);
end (*not constant*);
end (*UCHKL, UCHKH*);
UCHKF, UCHKT : (* peg 07jul79 *)
begin
with STK[TOP] do
begin
if DTYPE <> TYPUB then ERROR(WCHKF_CHKT_NEEDS_BOOLEAN);
if IS_CONSTANT(TOP) then
begin
if (OPC = UCHKF) and (FPA.MEMADR.DSPLMT = 1) then
ERROR(WBOOL_IS_TRUE)
else if (OPC = UCHKT) and (FPA.MEMADR.DSPLMT = 0) then
ERROR(WBOOL_NOT_TRUE);
end (*constant*)
else
begin (*non-constant*)
if BREPRES = BJUMP then BJUMP_TO_BINTVAL(TOP);
if OPC = UCHKF then
begin
LOWBOUND := 0;
HIGHBOUND := 0;
end
else (*UCHKT*)
begin
LOWBOUND := 1;
HIGHBOUND := 1;
end;
GET_OPERAND(OPND2, TOP);
XTNDED_REGDISP_OPERAND(OPND1, S1RPC, 0);
UPD_BOUNDTBL(OPND1.XW.DISP, HIGHBOUND, 0, TYPUB);
OPND1.FIXUP := BOUNDFIX;
EMITXOP(BTRP_N_X[LOWBOUND, TYPUB], OPND1, OPND2);
end (*not constant*);
end;
FREEDATUMREGS(TOP);
POPTOP;
end (*UCHKF, UCHKT*);
UCHKN : (* peg 07jul79 *)
begin
if STK[TOP].DTYPE = TYPUN then
ERROR(WCHKN_NULL_TOP)
else if STK[TOP].DTYPE <> TYPUA then
ERROR(WCHKN_NOT_ADDRESS);
if IS_CONSTANT(TOP) then
begin
if STK[TOP].FPA.MEMADR.DSPLMT < 0 then (*nil*)
ERROR(WCHKN_NULL_TOP);
end (*constant*)
else
begin (*not constant*)
HIGHBOUND := MAXS1ADDR;
GET_OPERAND(OPND2, TOP);
XTNDED_REGDISP_OPERAND(OPND1, S1RPC, 0);
UPD_BOUNDTBL(OPND1.XW.DISP, HIGHBOUND, 0, TYPUA);
OPND1.FIXUP := BOUNDFIX;
EMITXOP(BTRP_N_X[0, TYPUA], OPND1, OPND2);
end (*not constant*);
end (*UCHKN*);
end (*case OPC of*)
end (*CHECK_OPS*);
(*** ANI_CLASS: TYPE_CONV_OPS URND UTYP UTYP2 UCVT UCVT2 ***)
(**)
procedure TYPE_CONV_OPS;
begin
case OPC of
URND : (* peg 21jul79 *)
begin
if not ((IS_INTEGER[TYP]) and (IS_REAL[TYPO2])) then
ERROR(WWRONG_INSTR_DATATYPE);
if not IS_REAL[STK[TOP].DTYPE] then
ERROR(WFIX_OF_INVALID_TYPE);
if TYPO2 <> STK[TOP].DTYPE then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
COERCE_DATUM(TOP, TYP);
end (*URND*);
UTYP, UTYP2 : (* als/peg 19jul79 *)
begin
if OPC = UTYP then STE := TOP else STE := TOP-1;
with STK[STE] do
begin
if DTYPE <> TYPO2 then ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if TYPO2 in [TYPUB, TYPUC, TYPUI, TYPUJ, TYPUK, TYPUL, TYPUS] then
case TYPO2 of
TYPUB : NO_ERROR := TYP in [TYPUJ, TYPUL];
TYPUC : NO_ERROR := TYP in [TYPUJ, TYPUL];
TYPUI : NO_ERROR := TYP in [TYPUK, TYPUS];
TYPUJ : NO_ERROR := TYP in [TYPUC, TYPUL, TYPUS];
TYPUK : NO_ERROR := TYP in [TYPUJ, TYPUS];
TYPUL : NO_ERROR := TYP in [TYPUC, TYPUJ, TYPUS];
TYPUS : NO_ERROR := TYP in [TYPUI, TYPUJ, TYPUK, TYPUL];
end (*case*)
else NO_ERROR := false;
if not NO_ERROR then ERROR(WTYP_WITH_INVALID);
if TYP = TYPUS then (*Not implemented until *)
ERROR(WNOT_IMPLEMENTED) (* more than one length of *)
else if TYPO2 = TYPUS then (* sets exist. *)
ERROR(WNOT_IMPLEMENTED)
else if (TYPO2 = TYPUB) and (BREPRES=BJUMP) then (*pn*)
begin
BJUMP_TO_BINTVAL (TOP);
DTYPE := TYPQ;
COERCE_DATUM (STE, TYP);
end
else if (TYP = TYPUC) then COERCE_DATUM (STE, TYPQ) (*CHR*)
else if (TYPO2 = TYPUC) then (*ORD*)
begin
DTYPE := TYPQ;
COERCE_DATUM (STE,TYP);
end;
DTYPE := TYP;
end (*with STK[STE] do*);
end (*UTYP,UTYP2*);
UCVT, UCVT2 : (* peg 06jul79 *)
begin
if OPC = UCVT then STE := TOP else STE := TOP-1;
if STK[STE].DTYPE <> TYPO2 then
ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if TYPO2 in [TYPUI, TYPUJ, TYPUK, TYPUL, TYPUQ, TYPUR] then
case TYPO2 of
TYPUI : NO_ERROR := TYP in [TYPUC, TYPUJ, TYPUQ, TYPUR];
TYPUJ : NO_ERROR := TYP in [TYPUI, TYPUQ, TYPUR];
TYPUK : NO_ERROR := TYP in [TYPUC, TYPUL, TYPUQ, TYPUR];
TYPUL : NO_ERROR := TYP in [TYPUK, TYPUQ, TYPUR];
TYPUQ : NO_ERROR := TYP in [TYPUI, TYPUJ, TYPUK, TYPUL, TYPUR];
TYPUR : NO_ERROR := TYP in [TYPUI, TYPUJ, TYPUK, TYPUL, TYPUQ];
end (*case*)
else NO_ERROR := false;
if NO_ERROR then
begin
if TYPO2 in [TYPUJ, TYPUL] then
if IS_REAL[TYP] then
COERCE_INT_DATUM(STE)
else CVT_INT_DATUM(STE);
COERCE_DATUM(STE, TYP);
end
else ERROR(WCVT_WITH_INVALID);
end (*UCVT, UCVT2*);
end (*case OPC of*)
end (*TYPE_CONV_OPS*);
(*** ANI_CLASS: VIRT_STK_OPS UDUP USWP UIXA ***)
(**)
procedure VIRT_STK_OPS;
begin
case OPC of
UDUP : (* als/peg 02jul79 *)
begin
if TOP < BOT then ERROR(WDUP_ON_EMPTY_STACK);
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if not( (STK[TOP].DTYPE = TYP) or
((TYP = TYPUA) and (STK[TOP].DTYPE = TYPUN)) ) then
ERROR (WINSTR_TYPE_NOT_DATUM_TYPE);
(*pn 27sep79...*) if TYP = TYPUS then
FINDRGBLOCK(S1SETREP_SIZE)
(*...pn 27sep79*) else if IS_DOUBLE[TYP] then FINDRP else FINDRG;
OPRRG := NXTRG;
RESCODESTART := NEWINSTREC;
REG_OPERAND(OPNDR, OPRRG);
MOVE_QUANTITY(OPNDR, TOP);
PUSHTOP;
REG_DATUM(TOP, RESCODESTART, TYP, OPRRG);
end(*UDUP*);
USWP : (* als/peg 02jul79 *)
begin
if TOP <= BOT then ERROR(WSWP_NOT_2);
if not (TYP in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if not (TYPO2 in [TYPUA, TYPUB, TYPUC, TYPUI, TYPUJ,
TYPUK, TYPUL, TYPUM, TYPUQ, TYPUR, TYPUS]) then
ERROR(WWRONG_INSTR_DATATYPE);
if ((STK[TOP].DTYPE <> TYP) or (STK[TOP-1].DTYPE <> TYPO2)) then
ERROR(WSWP_TYP_ERROR);
BOOL_IN_STK := false; (* All of this may or may not *)
for STE := BOT to TOP do (* accomplish what we want it to, *)
if STK[STE].DTYPE = TYPUB then (* which is to prevent codefork *)
BOOL_IN_STK := true; (* side effects.*)
if BOOL_IN_STK then
for STE := BOT to TOP do
LOADSTKENTRY(STE); (*Prevent side effects*)
XCHANGE_STKENTS (TOP, TOP-1);
end(*USWP*);
UIXA : (* als/peg 29Jun79 *)
begin
if not (STK[TOP-1].DTYPE in [TYPUA, TYPUM]) then
ERROR(WIXA_NEEDS_ADDR);
if TYP in [TYPUI, TYPUK] then
ERROR(WNOT_IMPLEMENTED);
if I1 mod QWBITS <> 0 then ERROR(WALIGNMENT_ERROR)
else I1 := I1 div QWBITS;
%* with STK[TOP] do
if DTYPE in [TYPUB, TYPUC] then
begin
if (DTYPE=TYPUB) and (BREPRES=BJUMP) then
BJUMP_TO_BINTVAL (TOP);
DTYPE := TYPQ;
end; *\
if TYP in [TYPUJ, TYPUL] then
COERCE_INT_DATUM(TOP);
(*Multiply top of stack by I1.*)
with STK[TOP] do
if I1 <> 1 then
begin
COMBINABLE := false;
CALCULABLE := false;
SHIFTDIST := POWER2(I1);
RESCODESTART := CODESTART;
repeat
if (SHIFTDIST>=0) and (FPA.MEMADR.LVL=0) and
(FINALIND = IND0) and
((NVPAS=0) or
((NVPAS=1) and (VPA1.VSHIFT+SHIFTDIST<=SFLDMAX)))
or
IS_CONSTANT(TOP)
then
COMBINABLE := true
else if IS_CNST_PLUS_OPND(TOP) then
begin (*index is uncomplicated*)
CONSTPART := FPA.MEMADR.DSPLMT * I1;
FPA.MEMADR.DSPLMT := 0;
IMM_OPERAND (OPND1, I1);
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if not (not TOOMUCH2) then ASSERTFAIL('UIXA 001');
CALCULABLE := true
end (*index is uncomplicated*)
else
begin (*general case*)
FIT_IN_OPERAND (TOOMUCH2, OPND2, TOP);
if TOOMUCH2 then
SIMPLIFY (TOP)
else
begin
CONSTPART := 0;
IMM_OPERAND (OPND1, I1);
CALCULABLE := true;
end;
end (*general case*)
until COMBINABLE or CALCULABLE;
if CALCULABLE then
begin
MULT_SINGLE (DEST, OPND1, OPND2, TOP);
FREEREGSBUTTHESE (TOP, [DEST]);
REG_DATUM (TOP, RESCODESTART, TYPUJ, DEST);
FPA.MEMADR.DSPLMT := CONSTPART;
end (*CALCULABLE*)
else
begin (*COMBINABLE*)
FPA.MEMADR.DSPLMT := FPA.MEMADR.DSPLMT * I1;
if not ((NVPAS<=1) or (I1=1)) then ASSERTFAIL('UIXA 002');
if NVPAS = 1 then
VPA1.VSHIFT := VPA1.VSHIFT + SHIFTDIST;
CODESTART := RESCODESTART
end (*COMBINABLE*);
end (*with STK[TOP] do*);
(*Simplify datums until combinable. We cannot emit an add
to combine them since the result must be
an address, with its high order bits zero.*)
if IS_CONSTANT(TOP) and
(STK[TOP].FPA.MEMADR.DSPLMT = 0) then
(*index is zero so just discard it*)
else
begin (*non-zero index*)
while STK[TOP].FINALIND > IND0 do
SIMPLIFY (TOP);
while STK[TOP-1].FINALIND > IND0 do
SIMPLIFY (TOP-1);
if STK[TOP-1].NVPAS > 0 then
while STK[TOP].NVPAS > 1 do
SIMPLIFY (TOP);
if STK[TOP].NVPAS > 0 then
while STK[TOP-1].NVPAS > 1 do
SIMPLIFY (TOP-1);
if not ((STK[TOP].FINALIND = IND0) and
(STK[TOP-1].FINALIND = IND0) and
(STK[TOP].FPA.MEMADR.LVL = 0) and
(STK[TOP].NVPAS + STK[TOP-1].NVPAS <= 2) ) then
ASSERTFAIL('UIXA 003');
STK[TOP-1].FPA.MEMADR.DSPLMT :=
STK[TOP-1].FPA.MEMADR.DSPLMT + STK[TOP].FPA.MEMADR.DSPLMT;
if STK[TOP-1].NVPAS = 0 then
case STK[TOP].NVPAS of
0 : (*null case*);
1 : STK[TOP-1].VPA1 := STK[TOP].VPA1;
2 : begin
STK[TOP-1].VPA1 := STK[TOP].VPA1;
STK[TOP-1].VPA2 := STK[TOP].VPA2;
end
end (*case*)
else if STK[TOP-1].NVPAS = 1 then
begin
if STK[TOP].NVPAS = 1 then
STK[TOP-1].VPA2 := STK[TOP].VPA1
end;
STK[TOP-1].NVPAS :=
STK[TOP-1].NVPAS + STK[TOP].NVPAS;
end (*non-zero index*);
if RTBUSER = TOP then RTBUSER := TOP - 1;
POPTOP;
end (*UIXA*);
end (*case OPC of*)
end (*VIRT_STK_OPS*);
(*** ANI_CLASS: PROC_CALL_OPS UMST UPAR UCUP UICUP UCSP URET ***)
(**)
procedure PROC_CALL_OPS;
begin
case OPC of
UMST : (* als/peg 17jul79 *)
begin
if MSTTOP >= MAXMST then
ERROR (WFUNC_CALLS_NESTED_TOO_DEEPLY)
else
begin
SP_EXCESS := 0; (*SETPARMKLUDGE*)
MSTTOP := MSTTOP + 1;
with MSTSTK[MSTTOP] do
begin
DESTLEV := I1;
MSTCODESTART := NEWINSTREC;
if MSTTOP = 1 then
CURPARMREGS := CURRENT_PARMREG_COUNT
else CURPARMREGS := MIN(MAXPAREG, PWORDCOUNT);
end (*with MSTSTK[MSTTOP]*);
if (MSTTOP = 1) and (MSTSTK[MSTTOP].CURPARMREGS > 0) then
SAVE_PARMREGS;
PWORDCOUNT := 0;
if CURLVL = 1 then
OFFSET := FILE_OFFSET
else (*CURLVL > 1*)
OFFSET := R_OFFSET;
DSPL := MSTSTK[MSTTOP-1].EVALSAVESTART;
for STE := BOT to TOP do (*Save expression stack*)
with STK[STE] do
if NVPAS > 0 then
if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
begin (*Save BJUMP temp reg just in case used*)
DSPL := DSPL + WORDUNITS;
REGDISP_OPERAND(OPND1, DISPLAY, OFFSET - DSPL);
REG_OPERAND(OPNDR, VPA1.VPA.RGADR);
EMITXOP(XMOV_S_S, OPND1, OPNDR)
end (*Save BJUMP temp reg*)
else
begin
(*This datum's value may be susceptible to
change by side effect. Get it into eval
save area to protect it.*)
if IS_DOUBLE[DTYPE] then
DSPL := DSPL + DOUBLEWORDUNITS
else DSPL := DSPL + WORDUNITS;
REGDISP_OPERAND(OPND1, DISPLAY, OFFSET - DSPL);
MOVE_QUANTITY (OPND1, STE);
(**** Note: check for *)if not DAT_IS_T_REG(STE)
(* non-reg. expr. temp*) and not DAT_IS_FILADR(STE) then
begin (*arrange to restore it to a temp*)
if IS_DOUBLE[DTYPE] then FINDRP
else FINDRG;
REG_DATUM (STE, CODESTART, DTYPE, NXTRG);
end;
end (*get datum into eval save*);
FREE_TEMP_REGS;
RESERVE_PARMREGS(0);
MSTSTK[MSTTOP].EVALSAVESTART := DSPL;
if DSPL > EVALSAVE.SIZE then EVALSAVE.SIZE := DSPL;
PUSH_STKFRAME;
end (*no error*);
end (*UMST*);
UPAR :
begin
IF STK[TOP].DTYPE = TYPUM then (*pn*)
COERCE_DATUM (TOP, TYPUA);
if not( (STK[TOP].DTYPE = TYP) or
((TYP = TYPUA) and (STK[TOP].DTYPE = TYPUN)) ) then
ERROR(WINSTR_TYPE_NOT_DATUM_TYPE);
if STK[TOP].DTYPE = TYPUB then
begin (*SETPARMKLUDGE...*)
if STK[TOP].BREPRES = BJUMP then
BJUMP_TO_BINTVAL(TOP);
end
else if STK[TOP].DTYPE = TYPUS then
(*Large value parameters are passed by passing their address and
copying into the callee's local area. This applies to sets of
greater than two-word length (e.g., four-word sets). At present,
PCPASC (and therefore PTRANS) produces code to pass sets directly
in the caller and to copy them in the callee; therefore, SOPU
must coerce set parameters to TYPUA. This is accomplished by
allocating some space on top of the runtime stack, moving the
actual set there and adjusting the stack pointer appropriately,
and putting the new address of the set in a register (which will
probably be the correct parmreg). This problem should go away
soon when UPAS becomes fully operational -- peg 23sep79.*)
begin
FINDRG; OPRRG := NXTRG;
REG_OPERAND(OPNDR, OPRRG);
EMITXOP(XMOV_S_S, OPNDR, OPNDRSP);
ALLOC_EXCESS(S1SETREP_SIZE); (*must be deallocated in CUP*)
SP_EXCESS := SP_EXCESS + S1SETREP_SIZE;
REGDISP_OPERAND(OPND1, OPRRG, 0);
GET_OPERAND(OPND2, TOP);
EMITXOP(MOV_X_X[TYPUS], OPND1, OPND2);
FREEREGSBUTTHESE(TOP, [OPRRG]);
REG_DATUM(TOP, STK[TOP].CODESTART, TYPUA, OPRRG);
end (*if STK[TOP].DTYPE = TYPUS*); (*...SETPARMKLUDGE*)
if not ((PWORDCOUNT >= MAXPAREG)
or ((PWORDCOUNT = MAXPAREG) and (IS_DOUBLE[TYP]))) then
begin (*reg. parm*)
PREG := MINPARS1REG + PWORDCOUNT;
CORRECT := false;
LOADSTKENTRY(TOP); (*This may get it into the correct reg.*)
if DAT_IS_REG(TOP) then
if STK[TOP].VPA1.VPA.RGADR = PREG then
CORRECT := true;
if not CORRECT then (*move parameter to correct reg.*)
with MSTSTK[MSTTOP] do
begin
if not RISFREE[PREG] then ASSERTFAIL('UPAR 001');
if IS_DOUBLE[TYP] then
begin
if not RISFREE[succ(PREG)] then ASSERTFAIL('UPAR 002');
ALLOCRP(PREG);
S1OP := MOVMS_N[2];
end
else
begin
ALLOCRG(PREG);
S1OP := XMOV_S_S;
end;
GET_OPERAND(OPND2, TOP);
RESCODESTART := STK[TOP].CODESTART;
REG_OPERAND(OPND1, PREG);
EMITXOP(S1OP, OPND1, OPND2);
FREEDATUMREGS(TOP);
REG_DATUM(TOP, RESCODESTART, TYP, PREG);
end (*move parameter*);
end (*reg. parm*);
if IS_DOUBLE[TYP] then
PWORDCOUNT := PWORDCOUNT + 2
else
PWORDCOUNT := PWORDCOUNT + 1;
end (*UPAR*);
UCUP, UICUP: (*peg 09aug79*)
begin
if OPC = UICUP then PRMTOP := TOP-1
else PRMTOP := TOP;
if (PRMTOP - BOT) + 1 < I2 then
ERROR(W2_MANY_PARMS_SPECIFIED)
else if (PRMTOP - BOT) + 1 > I2 then
ERROR(WINSUFF_PARMS_SPECIFIED);
if not ((IS_INTEGER[TYP]) or (IS_REAL[TYP])
or (TYP in [TYPUA, TYPUB, TYPUC, TYPUP])) then
ERROR(WILLEGAL_PROC_TYPECODE);
if ((TYP = TYPUP) and (I3 <> 0))
or ((IS_INTEGER[TYP] or IS_REAL[TYP]
or (TYP in [TYPUA, TYPUB, TYPUC])) and (I3 <> 1)) then
ERROR(WWRONG_RESULT_NUMBER);
PARM := BOT;
LASTREGPARM := PARM;
PWORDCOUNT := 0;
EXCESS := 0;
while PARM <= PRMTOP do
begin (*check reg. parms for correct order, collect excess*)
if (PWORDCOUNT >= MAXPAREG)
or ((PWORDCOUNT = MAXPAREG) and (IS_DOUBLE[TYP])) then
if IS_DOUBLE[STK[PARM].DTYPE] then
EXCESS := EXCESS + 2 (*peg 24sep79*)
else EXCESS := EXCESS + 1 (*peg 24sep79*)
else
begin (*reg. parm*)
LASTREGPARM := PARM;
PREG := MINPARS1REG + PWORDCOUNT;
if not (DAT_IS_REG(PARM)
and (STK[PARM].VPA1.VPA.RGADR = PREG)) then
ASSERTFAIL('UCUP 001');
end (*reg. parm*);
if IS_DOUBLE[STK[PARM].DTYPE] then
PWORDCOUNT := PWORDCOUNT + 2
else PWORDCOUNT := PWORDCOUNT + 1;
PARM := PARM + 1;
end (*check reg. parms*);
MINTMPS1REG := PREG + 1;
MAXTMPS1REG := MAX(MAXTMPS1REG,MINTMPS1REG-1);
CHECK_DSP_TMP_COLLISION;
if EXCESS > 0 then (* move excess parms to stack top, *)
begin (* pass address of overflow area in RTB *)
if not RISFREE[S1RTB] then MOVE_AND_FREE_RTB;
ALLOCRG(S1RTB);
EMITXOP(XMOV_S_S, OPNDRTB, OPNDRSP);
ALLOC_EXCESS(EXCESS); (*peg 23sep79*)
DSPL := -EXCESS*WORDUNITS; (*peg 24sep79*)
for PARM := LASTREGPARM + 1 to PRMTOP do
begin
REGDISP_OPERAND(OPND1, S1RSP, DSPL);
MOVE_QUANTITY(OPND1, PARM);
if IS_DOUBLE[STK[PARM].DTYPE] then
DSPL := DSPL + DOUBLEWORDUNITS
else DSPL := DSPL + WORDUNITS;
end;
end (*move excess parms*);
if OPC = UCUP then
begin
REG_OPERAND(OPNDR, LVL_TO_S1REG[MSTSTK[MSTTOP].DESTLEV]);
EXT_REGADDR_OPERAND(OPND2, S1RPC, SEG_EP_RELPC); (*EJG*)
OPND2.FIXUP := XTRNSYMFIX;
UPD_PROCTBL(OPND2.FIXPTR, NAM1.NAM);
EMITJOP(XJSR, 0, OPNDR, OPND2, nil);
end
else
begin
(* put the address of the beginning of PSWITCH into a spare register *)
(* the problem with this is that XTRNSYMFIX doesn't work with
an XMOV instead of an XJSR *)
FINDRG; OPRRG := NXTRG;
REG_OPERAND (OPNDR,OPRRG);
EXT_REGADDR_OPERAND(OPND2, S1RPC, SEG_EP_RELPC);
OPND2.FIXUP := XTRNSYMFIX;
UPD_PROCTBL(OPND2.FIXPTR, PSWITCHNAME);
EMITXOP(XMOV_S_S, OPNDR, OPND2);
(* now use the procedure number as index *)
COERCE_DATUM (TOP, TYPUJ);
if IS_CONSTANT(TOP) then ERROR (WNOT_IMPLEMENTED);
GET_SHORT_OPERAND (OPND, TOP);
OPND2 := OPND;
OPND2.X := 1;
OPND2.XW.V := 1;
OPND2.XW.S := DALIGNSHIFT;
OPND2.XW.REG := OPRRG;
OPND2.XW.DISP := 0;
REG_OPERAND(OPNDR, LVL_TO_S1REG[4]);
JUMPINDEXED := NEWINSTREC;
EMITJOP(XJSR, 0, OPNDR, OPND2, nil);
ADD_INSTPTR_TO_OPND2FIXLIST (NEG_SHIFT_FIXLIST, JUMPINDEXED);
FREEDATUMREGS(TOP);
POPTOP;
FREERG_S(OPRRG);
end;
if EXCESS > 0 then (*restore SP*)
begin
FREERG_S(S1RTB); (*peg 23sep79*)
DEALLOC_EXCESS(EXCESS); (*peg 23sep79*)
end (*restore SP*);
if SP_EXCESS > 0 then (*SETPARMKLUDGE...*)
begin
DEALLOC_EXCESS(SP_EXCESS);
SP_EXCESS := 0;
end; (*...SETPARMKLUDGE*)
while TOP >= BOT do (*free parm regs. ...*)
with STK[TOP] do
begin
if DAT_IS_REG(TOP) then FREERG_S(VPA1.VPA.RGADR)
else FREEDATUMREGS(TOP);
POPTOP;
end; (*... free parm regs.*)
FREE_TEMP_REGS;
if MSTTOP > 1 then
begin
PWORDCOUNT := MSTSTK[MSTTOP].CURPARMREGS;
RESERVE_PARMREGS(0);
end
else
RESERVE_PARMREGS(MSTSTK[MSTTOP].CURPARMREGS);
POP_STKFRAME;
with MSTSTK[MSTTOP-1], CURPROCSPEC do
begin (*Restore expr stack and parmregs.*)
RTBSAVED := false;
if CURLVL = 1 then
OFFSET := FILE_OFFSET
else (*CURLVL > 1*)
OFFSET := R_OFFSET;
DSPL := EVALSAVESTART;
for STE := BOT to TOP do
with STK[STE] do
if NVPAS > 0 then
if (DTYPE = TYPUB) and (BREPRES = BJUMP) then
begin (*Restore BJUMP temp reg*)
REG_OPERAND(OPNDR, VPA1.VPA.RGADR);
DSPL := DSPL + WORDUNITS;
ALLOCRG(VPA1.VPA.RGADR);
REGDISP_OPERAND(OPND2, DISPLAY, OFFSET - DSPL);
EMITXOP(XMOV_S_S,OPNDR,OPND2)
end (*Restore BJUMP temp reg*)
else
begin (*Restore one expr temp.*)
if not (DAT_IS_T_REG(STE) or DAT_IS_FILADR(STE) ) then
ASSERTFAIL('UCUP 002');
FIT_IN_OPERAND (TOOMUCH1, OPND1, STE);
if TOOMUCH1 then ASSERTFAIL('UCUP 003');
if IS_DOUBLE[DTYPE] then DSPL := DSPL + DOUBLEWORDUNITS
else DSPL := DSPL + WORDUNITS;
if (TYP<>TYPUP) and IS_RTB(OPND1) then
begin
(*We will be getting a function value back in
RTB, so remember to restore the thing
which was there into another temporary,
after restoring all the others so we know
which ones are available.*)
RTBSAVED := true;
RTBDATUM := STE;
RTBDSPL := DSPL;
end (*RTB*)
else
begin (*ordinary temporary*)
if DAT_IS_T_REG(STE) then
if IS_DOUBLE[DTYPE] then
ALLOCRP(VPA1.VPA.RGADR)
else ALLOCRG(VPA1.VPA.RGADR);
REGDISP_OPERAND(OPND2, DISPLAY, OFFSET - DSPL);
EMITXOP (MOV_X_X[DTYPE], OPND1, OPND2);
end (*ordinary temp reg*);
end (*restore one expr temp*);
if RTBSAVED then
with STK[RTBDATUM] do
begin (*Restore it somewhere else*)
if IS_DOUBLE[DTYPE] then
begin FINDRP; S1OP := XMOV_D_D; end
else
begin FINDRG; S1OP := XMOV_S_S; end;
VPA1.VPA.RGADR := NXTRG;
REG_OPERAND (OPNDR, NXTRG);
REGDISP_OPERAND(OPND2, DISPLAY, OFFSET - RTBDSPL);
EMITXOP (S1OP, OPNDR, OPND2);
end (*if RTBSAVED*);
if MSTTOP = 1 then RESTORE_PARMREGS;
end (*Restore expr stack and parmregs.*);
if TYP <> TYPUP then
begin (*Function value being returned in RTB.*)
PUSHTOP;
if IS_DOUBLE[TYP] then ALLOCRP (S1RTB) else ALLOCRG (S1RTB);
REG_DATUM (TOP, MSTSTK[MSTTOP].MSTCODESTART, TYP, S1RTB);
RTBUSER := TOP;
RTBDOUB := IS_DOUBLE[TYP];
end (*function value being returned*);
MSTTOP := MSTTOP - 1;
end (*UCUP*);
UCSP : CALLSTANDARD;
URET : (* als/peg 29Jun79 *)
with CURPROCSPEC do
begin
REG_OPERAND (OPNDR, DISPLAY);
if DEBUG then
begin
if CURLVL = 1 then
XTNDED_REGDISP_OPERAND (OPND2, DISPLAY,
-WORDUNITS - L1DISPLAY_OFFSET
(*- Eval save size by fixup*) )
else (*CURLVL > 1*)
XTNDED_REGDISP_OPERAND (OPND2, DISPLAY,
-WORDUNITS - DISPLAY_OFFSET
(*- Eval save size by fixup*) );
ADDR_OPERAND (OPND1, S1GSEGBASE*WORDUNITS);
INSTLOC := NEWINSTREC;
EMITXOP (XMOV_S_S, OPND1, OPND2);
ADD_INSTPTR_TO_OPND2FIXLIST (EVALSAVE.NEGFIXLIST, INSTLOC); (*DATASTRCH*)
if CURLVL = 1 then
XTNDED_REGDISP_OPERAND (OPND2, DISPLAY,
-WORDUNITS - L1DISPLAY_OFFSET
(*LCW) (*- Eval save size by fixup*) )
else (*CURLVL > 1*)
XTNDED_REGDISP_OPERAND (OPND2, DISPLAY,
-WORDUNITS - DISPLAY_OFFSET
(*LCW*) (*- Eval save size by fixup*) );
end
else
if CURLVL = 1 then
XTNDED_REGDISP_OPERAND (OPND2, DISPLAY, -L1DISPLAY_OFFSET
(*LCW*) (*- Eval save size by fixup*) )
else (*CURLVL > 1*)
XTNDED_REGDISP_OPERAND (OPND2, DISPLAY, -DISPLAY_OFFSET
(*LCW*) (*- Eval save size by fixup*) );
INSTLOC := NEWINSTREC;
EMITXOP (XRETSR, OPNDR, OPND2);
ADD_INSTPTR_TO_OPND2FIXLIST (EVALSAVE.NEGFIXLIST, INSTLOC); (*DATASTRCH*)
end (*URET*);
end (*case OPC of*)
end (*PROC_CALL_OPS*);
(*** ANI_CLASS: IMP_EXP_OPS UIMPP UIMPV UEXPP UEXPV ***)
(**)
procedure IMP_EXP_OPS;
begin
case OPC of
UIMPP :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UIMPP*);
UIMPV :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UIMPV*);
UEXPP :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UEXPP*);
UEXPV :
begin
ERROR (WNOT_IMPLEMENTED);
end (*UEXPV*);
end (*case OPC of*)
end (*IMP_EXP_OPS*);
(*** ANI_CLASS: COMP_TIME_OPS UCOMM UOPTN ULEX USYM ULIVE UDEAD UDOA UDEF UMDEF ULOC ***)
(**)
procedure COMP_TIME_OPS;
begin
case OPC of
UCOMM : (* als/peg 29Jun79 *)
begin
(* COMM is currently a no-op. *)
end (*UCOMM*);
UOPTN : (*only enough letters used to disambiguate*)
begin
if NAM1.NAM[1] = 'T' then
begin
NO_ERROR := true;
if NAM1.NAM[2] = 'A' then ASM := I1 = 1
else if NAM1.NAM[2] = 'D' then DEBUG := I1 = 1
else if NAM1.NAM[2] = 'M' then
begin
if I1 = 0 then TR_MST := false
else if I1 = 1 then TR_MST := true
else if I1 < 0 then
PRINT_MSTENTRY (-I1)
else NO_ERROR := false;
end
%* else if NAM1.NAM[2] = 'N' then (* commented out -- peg 18jul79 *)
begin
if I1 = 0 then TR_NEST := false
else if I1 = 1 then TR_NEST := true
else PRINT_NESTITEM (I1)
end *\(*end comment out *)
else if NAM1.NAM[2] = 'P' then
begin
if NAM1.NAM[6] = 'H' then
if I2 = 1 then NO_JMPX_TO_JMPA_FLG := I1 = 0
else if I2 = 2 then NO_SKIP_JMPA_FLG := I1 = 0
else if I2 = 3 then NO_COLLAPSE_MOV_FLG := I1 = 0
else if I2 = 4 then NO_INC_SKP_FLG := I1 = 0
else NO_ERROR := false
else if NAM1.NAM[6] = 'O' then
begin
NO_JMPX_TO_JMPA_FLG := I1 = 0;
NO_SKIP_JMPA_FLG := I1 = 0;
NO_COLLAPSE_MOV_FLG := I1 = 0;
NO_INC_SKP_FLG := I1 = 0;
end
else if NAM1.NAM[6] = 'T' then TR_PEEPHOLE := I1 = 1
else NO_ERROR := false;
end
else if NAM1.NAM[2] = 'S' then
begin
if NAM1.NAM[3] = '1' then
if I1 = 0 then TR_S1CODE := false
else if I1 = 1 then TR_S1CODE := true
else if I1 = -1 then
begin
IPTR := MAINCODE.FIRST;
S1PC := SEG_EP_RELPC;
while IPTR <> nil do
begin
DISASSEMBLE (S1PC, IPTR);
IPTR := IPTR↑.NEXTPTR; (*DATASTRCH*)
end;
end
else NO_ERROR := false
else if NAM1.NAM[3] = 'I' then
if I1 = 0 then TR_SIMP := false
else if I1 = 1 then TR_SIMP := true
else if I1 < 0 then SIMPLIFY (-I1)
else NO_ERROR := false
else if NAM1.NAM[3] = 'T' then
if I1 = 0 then TR_STACK := false
else if I1 = 1 then TR_STACK := true
else if I1 < 0 then PRINTDATUM (-I1)
else NO_ERROR := false
else NO_ERROR := false;
end
else if NAM1.NAM[2] = 'U' then TR_UCODE := I1 = 1
else NO_ERROR := false;
if (not NO_ERROR) and TR_UCODE then
writeln(OUTPUT,'*** WARNING: Invalid or unrecognized OPTN ***');
end;
end (*UOPTN*);
ULEX : (* als/peg 09jul79 *)
begin
if (I2 < MINBLOCK) or (I2 > MAXBLOCK) then
ERROR(WINVAL_BLOCK_NUMBER);
BLOCKTABLE[I2] := I1;
end (*ULEX*);
USYM : (* als/peg 09jul79 *)
begin
(* NOTE: this instruction will remain unimplemented until some specifications
for a symbolic debugger and the information it needs (and where it will go,
etc.) have been created -- als/peg.*)
(* SYM is currently a no-op. *)
end (*USYM*);
ULIVE : (* als/peg 09jul79 *)
begin
(* LIVE is currently a no-op. *)
end (*ULIVE*);
UDEAD : (* als/peg 09jul79 *)
begin
(* DEAD is currently a no-op. *)
end (*UDEAD*);
UDOA : (* als/peg 09jul79 *)
begin
(* DOA is currently a no-op. *)
end (*UDOA*);
UDEF : (* als/peg 13jul79 *)
begin
if I1 mod WORDBITS <> 0 then
ERROR(WALIGNMENT_ERROR);
with CURPROCSPEC do
if MTYP = R_SPACE then
R_MEMORY_AREA := REGIMAGEAREASIZE*QWBITS
else if MTYP = M_SPACE then
begin
M_MEMORY_AREA := I1;
STACKFRAME.SIZE := STACKFRAME.SIZE + (I1 div QWBITS);
end
else ERROR (WNOT_IMPLEMENTED);
end (*UDEF*);
UMDEF :
begin
(* NOTE: See Universal P-Code Definition, version [0.2] for details on
this instruction. A minimum implementation, allowing consistency checks
between this instruction and memory usage, should be easily implementable,
but requires some new data structures and routines; these should be care-
fully thought out -- peg.*)
end (*UMDEF*);
ULOC : (**** als should fix this.*)
(* LOC <line number> <page number> <stmt count> <basblock?>
where:
<line number> and <page number> refer to the original PASCAL source file.
<stmt count> is the number of the statement in that line
<basblock?> is one if this is the first statement of a basic block,
zero otherwise.*)
begin
CURPLOC := I1;
(*A 'LOC 0' precedes each procedure, at which time the code list
has not yet been initialized. Hence do not emit a ULOC fake
instruction in that case.*)(**** Is this still true??*)
if I1 > 0 then
begin
if DEBUG then EMITFAKEOP (XPLOC, I1);
end;
end (*ULOC*);
end (*case OPC of*)
end (*COMP_TIME_OPS*);
(*** ANI_CLASS: ***)
(**)
(*** ANI ==> ASSEMBLE_NEXT_INSTRUCTION ***)
begin (*ASMNXTINST*)
if JUMPTABLE_IN_PROGRESS then
JUMPTABLE_IN_PROGRESS :=
(OPC=UUJP) or (OPC=ULAB) or (OPC=UDEF) or (OPC=ULOC)
or (OPC=UBGN)
else
JUMPTABLE_IN_PROGRESS := false;
(*Some operations are available as both instructions and
as standard procedures. Translate such into either one or the
other to avoid duplication of effort.*)
(* Requires PASCAL-UCode compilers to emit CSP NEW/DSP!!!*)
%
if (OPC = UNEW) or (OPC = UDSP) then
begin
NAM1.LEN := 3;
if OPC = UDSP then
begin
NAM1.NAM := 'DSP '
end (*if OPC = UDSP*)
else if OPC = UNEW then
begin
NAM1.NAM := 'NEW ';
PUSHTOP;
STK[TOP] := ZERODATUM;
with STK[TOP] do
begin
CODESTART := NEWINSTREC;
DTYPE := TYPUJ;
FPA.MEMADR.DSPLMT := I1;
end;
OPC := UCSP;
end (*if OPC = UNEW*)
end (*if (OPC = ...*); \
case OPC of
UABS, UNEG, UADD, UINC, UDEC : ARITH_1_OPS;
USUB : ARITH_2_OPS;
UMPY, USQR : ARITH_3_OPS;
UDIV, UDMD, UMOD : ARITH_4_OPS;
UEQU, UGEQ, UGRT, ULEQ, ULES,
UNEQ, UIEQU,UIGEQ,UIGRT,UILEQ,
UILES,UINEQ : REL_OPS;
UAND, UIOR, UXOR, UNOT, UODD : BOOL_OPS;
UDIF, UINT, UUNI, UINN, USGS,
UADJ, UMUS : SET_OPS;
ULCA, ULDA, ULDC, ULOD, ULDP,UILOD,
UPLOD : LOAD1_STORE_OPS;
USTR,UNSTR,UISTR,UINST,UPSTR, UMOV :
LOAD2_STORE_OPS;
UFJP, UTJP, UUJP, UXJP,UGOOB,
ULAB,UCLAB : FLOW_CONTROL_OPS;
UBGN, UEND, USTP, UENT,UBGNB,
UENDB : ENVIRONMENT_OPS;
UCHKL,UCHKH,UCHKT,UCHKF,UCHKN : CHECK_OPS;
URND, UTYP, UTYP2, UCVT,UCVT2 : TYPE_CONV_OPS;
UDUP, USWP, UIXA : VIRT_STK_OPS;
UMST, UPAR, UCUP,UICUP, UCSP,
URET : PROC_CALL_OPS;
UIMPP,UIMPV,UEXPP,UEXPV : IMP_EXP_OPS;
UCOMM,UOPTN, ULEX, USYM,ULIVE,
UDEAD, UDOA, UDEF,UMDEF, ULOC : COMP_TIME_OPS;
UNEW, UDSP : ERROR(WNOT_IMPLEMENTED);
end (*case OPC of*);
end (*ASMNXTINST*);
(** READNXTINST_CLASS: READNXTINST READNAM READTYP READMTYP READINT READREAL READSTRING READSET UUNK *)
(**)
procedure READNXTINST;
(*Read next P-Code instruction and convert it to internal form.*)
var CH : char;
procedure READNAM (var NAM : NAMEREC);
(*Skip initial blanks and commas and read a
label or procedure identifier into NAM.*)
var I : 0..ALFASIZE;
CH : char;
begin
while (INPUT↑=' ') or (INPUT↑=',') do
get (INPUT);
NAM.NAM := ' ';
I := 0;
repeat
I := I + 1;
READ (INPUT, CH);
NAM.NAM[I] := CH
until (I=ALFASIZE) or (INPUT↑=' ') or (INPUT↑=',');
while (INPUT↑<>' ') and (INPUT↑<>',') do
get (INPUT);
NAM.LEN := I;
end (*READNAM*);
procedure READTYP (var TYP : OPNDTYPE);
(*Skip initial blanks and commas and read a
type character. Translate it into an
OPNDTYPE and return it in TYP.*)
var CH : char;
begin
repeat
READ (INPUT, CH)
until (CH <> ' ') and (CH <> ',');
TYP := FIRSTTYPE;
while (TYP < LASTTYPE) and (TYPECODE[TYP] <> CH) do
TYP := succ(TYP);
if TYPECODE[TYP] <> CH then
ERROR (WINVAL_U_TYPECODE);
end (*READTYP*);
procedure READMTYP (var TYP : MEMTYPE);
(*Skip initial blanks and commas and read a
type character. Translate it into a
MEMTYPE and return it in TYP.*)
var CH : char;
begin
repeat
READ (INPUT, CH)
until (CH <> ' ') and (CH <> ',');
TYP := FIRSTMTYPE;
while (TYP < LASTMTYPE) and (MTYPECODE[TYP] <> CH) do
TYP := succ(TYP);
if MTYPECODE[TYP] <> CH then
ERROR (WINVALID_MEMORY_TYPE);
end (*READTYP*);
procedure READINT (var I : integer);
(*Skip initial blanks and commas and read an
integer into I.*)
begin
while (INPUT↑=' ') or (INPUT↑=',') do
get (INPUT);
READ (INPUT, I);;
end (*READINT*);
procedure READREAL (var R : real);
(*Skip initial blanks and commas and read a
real number into R.*)
begin
while (INPUT↑=' ') or (INPUT↑=',') do
get (INPUT);
READ (INPUT, R);;
end (*READREAL*);
(* Comment out the 370 version...
procedure READSET(var S : SETREP);
%*Read an input-format set and convert it to a SETREP,
returning it in S. This procedure changes when
sets get bigger for the real machine.*\
var SETINT :
record
DUMMY : integer; %*alignment (not needed?)*\
case BIT of
0 : (S : SETREP);
1 : (I : array[1..2] of integer)
end %*SETINT*\;
INT1, INT2 : integer;
begin
while INPUT↑ <> '(' do get(INPUT);
get(INPUT);
READINT(INT1);
READINT(INT2);
SETINT.I[1] := INT1*TWOEXP[16] + INT2;
READINT(INT1);
READINT(INT2);
SETINT.I[2] := INT1*TWOEXP[16] + INT2;
S := SETINT.S
end %*READSET*\;
...*)
procedure READSET(var S : SETREP);
(*Read a set as a string of octal digits and convert it to a SETREP,
returning it in S. PDP-10 version. *)
(* pn 19SEP79 *)
var J, N : integer;
CH : char;
begin
while (INPUT↑=' ') do get (INPUT);
S := NULL_SET;
N := 0;
while N < SET_SIZE do
begin
read (INPUT, CH);
J := ORD (CH) - ORD ('0');
if J > 3 then BUILD_SET(S,N);
if (J mod 4) > 1 then BUILD_SET(S,N+1);
if odd(J) then BUILD_SET(S,N+2);
N := N + 3;
end
end (*READSET*);
procedure READSTRING(var STRVAL : STRINGTYPE; var STRLGTH : STRINX);
(*Read a string into STRVAL -- als/peg 24jul7.*)
var CH : char;
begin
WHILE (CH <> '''') and not eoln (INPUT) do READ (CH);
READ (CH);
STRLGTH := 0;
while (CH<>'''') or (INPUT↑='''') do
begin
STRLGTH := STRLGTH + 1;
SVAL[STRLGTH] := CH;
if CH = '''' then READ (CH);
READ (CH);
end (*while*);
end (*READSTRING*);
begin (*READNXTINST*)
if INPUT↑ <> ' ' then READNAM (NAM0);
repeat get(INPUT) until INPUT↑ <> ' ';
READ(CH); MNEM[1] := CH;
READ(CH); MNEM[2] := CH;
READ(CH); MNEM[3] := CH;
if INPUT↑ = ' ' then CH := ' ' else READ(CH);
MNEM[4] := CH;
OPC := MNEM_TO_OPC(MNEM);
case OPC of
UCHKF, UCHKN, UCHKT, URET :
(*null case*);
UCLAB, ULAB, UMST, UNEW, UPLEX :
READINT (I1);
UGOOB, UEXPP, UIMPP, UIMPV :
begin
READINT (I1);
READNAM (NAM1);
end;
ULEX : begin
READINT (I1);
READINT (I2);
end;
ULDP : begin
READINT (I1);
READINT (I2);
READNAM (NAM1);
end;
ULOC : begin
READINT (I1);
READINT (I2);
READINT (I3);
READINT (I4);
end;
UEND : READNAM (NAM1);
UBGN, UFJP, UUJP, USTP , UTJP:
READNAM (NAM1);
UOPTN : begin
READNAM (NAM1);
READINT (I1);
if (NAM1.NAM[1] = 'P') and (NAM1.NAM[6] = 'H') then
READINT (I2);
end;
UABS, UADD, USUB, UMPY, UDIV, UAND, UDIF, UDMD, UDSP, UDUP,
UEQU, UNEQ, UGEQ, UGRT, ULEQ, ULES, UIEQU,UINEQ,UIGEQ,UIGRT,
UILEQ,UILES,UINN, UINT, UIOR, UMOD, UMUS, UNEG, UNOT, UODD,
USDEF,USGS, USQR, UUNI :
READTYP (TYP);
UCVT, UCVT2, URND, USWP, UTYP, UTYP2 :
begin
READTYP (TYP);
READTYP (TYPO2);
end;
UDEC, UINC, UIXA, UMOV :
begin
READTYP (TYP);
READINT (I1);
end;
UCHKL, UCHKH :
begin
READTYP (TYP);
READINT (I1);
end;
UADJ, UILOD, UINST, UISTR:
begin
READTYP (TYP);
READINT (I1);
READINT (I2);
end;
UENT : begin
READTYP (TYP);
READINT (I1);
READINT (I2);
READINT (I3);
READINT (I4);
end;
UDEF : begin
READMTYP (MTYP);
READINT (I1);
end;
UDEAD, UDOA, UEXPV, ULDA, ULIVE :
begin
READMTYP (MTYP);
READINT (I1);
READINT (I2);
READINT (I3);
end;
UMDEF : begin
READMTYP (MTYP);
READINT (I1);
READINT (I2);
READINT (I3);
while (CH = ' ') and not eoln(INPUT) do READ(CH);
SLGTH := 0;
while (SLGTH < STRINGMAX) and not eoln(INPUT) do
begin
READ (CH);
SLGTH := SLGTH + 1;
SVAL[SLGTH] := CH;
end (*while*);
end;
UXJP :
begin
READTYP (TYP);
READNAM (NAM1);
READNAM (NAM2);
READINT (I1);
READINT (I2);
end;
ULOD, UNSTR, UPAR, UPLOD, UPSTR, USTR, USYM :
begin
READTYP (TYP);
READMTYP (MTYP);
READINT (I1);
READINT (I2);
READINT (I3);
end;
UCSP : begin
READTYP (TYP);
READNAM (NAM1);
READINT (I1);
READINT (I2);
end;
UCUP, UICUP :
begin
READTYP (TYP);
if OPC = UCUP then
begin
READINT (I1);
READNAM (NAM1);
end;
READINT (I2);
READINT (I3);
end;
ULDC : begin
READTYP (TYP);
READINT (I1);
case TYP of
TYPUI, TYPUK, TYPUM, TYPUQ :
ERROR(WNOT_IMPLEMENTED);
TYPUB, TYPUJ, TYPUL :
READINT (I2);
TYPUC : READSTRING (SVAL, SLGTH);
TYPUR : READREAL (R1);
TYPUN : (*null case*);
TYPUS : READSET (P1);
end (*case TYP of*);
end (*ULDC*);
ULCA : begin
READTYP (TYP);
READINT (I1);
case TYP of
TYPUI, TYPUK, TYPUQ :
ERROR(WNOT_IMPLEMENTED);
TYPUB, TYPUJ, TYPUL :
READINT (I2);
TYPUC : READSTRING (SVAL, SLGTH);
TYPUR : READREAL (R1);
TYPUS : READSET (P1);
TYPUM : READSTRING (SVAL, SLGTH);
end (*case TYP of*);
end (*ULCA*);
UCOMM :
begin (* pn *)
while (CH = ' ') and not eoln(INPUT) do READ(CH);
CLEN := 0;
while not eoln(INPUT) and (CLEN < COMMLEN) do
begin
CLEN := CLEN + 1;
READ(CH); COMMFIELD[CLEN] := CH;
end;
end (*UCOMM*);
UUNK : begin
READINT (I2);
READINT (I3);
while (CH = ' ') and not eoln(INPUT) do READ(CH);
(* READSTRING (SVAL, SLGTH); *)
end;
end (*case OPC of*);
READLN(INPUT);
end (*READNXTINST*);
(** INITIALIZE_CLASS: INITIALIZE ENTER_OPC ENTER_CSP INIT1 **)
(**)
procedure INITIALIZE;
var
I, N : integer;
T, T1, T2 : OPNDTYPE;
S1OP : S1OPCODE;
procedure ENTER_OPC (NAM : CHAR4; OPC : U_OPCODE); (*ALS*)
var H : 0..OPCHTSIZEM1;
begin
H := OPC_HASH(NAM);
while OPCHASHTAB[H].OPCNAM <> ' ' do
H := (H + 1) mod OPCHTSIZE;
OPCHASHTAB[H].OPCNAM := NAM;
OPCHASHTAB[H].OPC := OPC;
end (*ENTER_OPC*);
procedure ENTER_CSP (NAM : CHAR3; CSP : P_STANDARDPROC);
var H : 0..CSPHTSIZEM1;
NAMALFA : ALFA;
begin
NAMALFA := ' ';
NAMALFA[1]:=NAM[1]; NAMALFA[2]:=NAM[2]; NAMALFA[3]:=NAM[3];
H := CSP_HASH(NAMALFA);
while CSPHASHTAB[H].CSPNAM.NAM <> ' ' do
H := (H + 1) mod CSPHTSIZE;
CSPHASHTAB[H].CSPNAM.NAM := NAMALFA;
CSPHASHTAB[H].CSPNAM.LEN := 3;
CSPHASHTAB[H].CSP := CSP;
end (*ENTER_CSP*);
procedure INIT1;
begin
(*%IFF SET4*)
for I := 0 to SETREP_MAX DO
NULL_SET[I] := [ ];
(*%ELSE*)
% NULL_SET := [ ]; \
(*%ENDC*)
for I := MINBLOCK to MAXBLOCK do
BLOCKTABLE[I] := ILLBLOCKNO;
ZEROS1WORD.LHALF := 0; ZEROS1WORD.RHALF := 0;
with EMPTY_OP do
begin
X := 0;
REG := 0; F := 0;
FIXUP := NOFIX; FIXPTR := nil;
XW.FMT := XW_EV; XW.P := 0;
XW.V := 0; XW.D := 0;
XW.I := 0; XW.S := 0;
XW.ADDR := 0; XW.REG := 0;
XW.DISP := 0;
end (*EMPTY_OP*);
with ZERO_OP do
begin
X := 0;
REG := 1; F := 0;
FIXUP := NOFIX; FIXPTR := nil;
XW.FMT := XW_C; XW.VAL := ZEROS1WORD;
end (*ZERO_OP*);
with EXTENDED_ZERO_OP do
begin
X := 1;
REG := 1; F := 1;
FIXUP := NOFIX; FIXPTR := nil;
XW.FMT := XW_C; XW.VAL := ZEROS1WORD;
end (*EXTENDED_ZERO_OP*);
with EMPTYCODELIST do
begin
NWORDS := 0;
FIRST := nil; LAST := nil;
end (*EMPTYCODELIST*);
with EMPTYOPND2FIXLIST do (*DATASTRCH*)
begin
NWORDS := 0;
FIRST := nil; LAST := nil;
end (*EMPTYOPND2FIXLIST*);
with EMPTYOPNDXWORDFIXLIST do (*DATASTRCH*)
begin
NWORDS := 0;
FIRST := nil;
LAST := nil;
end(*EMPTYOPNDXWORDFIXLIST*);
with EMPTYINSTLIST do (*DATASTRCH*)
begin
NWORDS := 0;
FIRST := nil;
LAST := nil;
end(*EMPTYINSTLIST*);
with EMPTYJUMPLIST do
begin
NWORDS := 0;
FIRST := nil; LAST := nil;
end (*EMPTYJUMPLIST*);
with ZEROFPA do
begin
WHICH := MEM;
MEMADR.LVL := 0; MEMADR.DSPLMT := 0;
end (*ZEROFPA*);
with ZEROVPA do
begin
VSHIFT := 0; VPAIND := IND1;
VPA.WHICH := MEM;
VPA.MEMADR.LVL := 0;
VPA.MEMADR.DSPLMT := 0;
end (*ZEROVPA*);
with ZERODATUM do
begin
CODESTART := nil;
DTYPE := TYPUP; (*no legal datum should be*)
DLENGTH := 0;
MTYPE := NON_SPACE;
BREPRES := BINTVAL;
BTRUELIST := EMPTYJUMPLIST;
BFALSELIST := EMPTYJUMPLIST;
BFALLTHRUSKIPLOC := nil;
BJUMPON := false;
SCNST := NULL_SET; RCNST := 0.0; (*setch*)
FINALIND := IND0; FPA := ZEROFPA;
NVPAS := 0;
VPA1 := ZEROVPA; VPA2 := ZEROVPA;
end (*ZERODATUM*);
with CURPROCSPEC do (* peg 18jul79...*)
begin (*Set up dummy entry*)
PROCTYPE := TYPUP;
PROCNAM.NAM := 'DUMMY ';
PROCNAM.LEN := 5;
REGPARMAREA := 0;
R_MEMORY_AREA := MIN_ON_COMP_MACH;
M_MEMORY_AREA := MIN_ON_COMP_MACH;
end (*CURPROCSPEC*); (*...peg 18jul79 *)
REG_OPERAND (UNUSED_OP, S1R0); (*unused operands must specify R0*)
REG_OPERAND (OPNDRTB, S1RTB);
REG_OPERAND (OPNDRSP, S1RSP);
SEG_EP_RELPC := SEG_START_RELPC + SEG_EP_DISP;
FIRSTTYPE := ILLARITH; LASTTYPE := TYPUS;
FIRSTMTYPE := NON_SPACE; LASTMTYPE := M_SPACE;
DEFAULTMTYPE := M_SPACE;
FIRSTS1OP := XILLEGAL; LASTS1OP := XXOR_Q;
FIRSTSKIP := XDSKP_EQL; LASTSKIP := XSKP_ANY_D; (*28JUN79 PTZ*)
TWOEXP[0] := 1;
for I := 1 to MAX_EXP_ON_COMP_MACH do TWOEXP[I] := 2 * TWOEXP[I-1];
MAXTMPS1REG := MINPARS1REG - 1;
MINDSPS1REG := MAXDSPS1REG + 1;
JUMPTABLE_IN_PROGRESS := false;
MTYPECODE[NON_SPACE] := ' ';
MTYPECODE[R_SPACE] := 'R';
MTYPECODE[M_SPACE] := 'M';
TYPECODE[TYPUA] := 'A'; (*address*)
TYPECODE[TYPUB] := 'B'; (*boolean*)
TYPECODE[TYPUC] := 'C'; (*character*)
TYPECODE[TYPUE] := 'E'; (*entry point of proc. as parameter*)
TYPECODE[TYPUI] := 'I'; (*double-word integer*)
TYPECODE[TYPUJ] := 'J'; (*single-word integer*)
TYPECODE[TYPUK] := 'K'; (*double-word non-neg. integer*)
TYPECODE[TYPUL] := 'L'; (*single-word non-neg. integer*)
TYPECODE[TYPUM] := 'M'; (*record, array*)
TYPECODE[TYPUN] := 'N'; (*nil pointer*)
TYPECODE[TYPUP] := 'P'; (*procedure*)
TYPECODE[TYPUQ] := 'Q'; (*double-word real*)
TYPECODE[TYPUR] := 'R'; (*single-word real*)
TYPECODE[TYPUS] := 'S'; (*set*)
ALIGNBNDRY[TYPUA] := WORDUNITS;
ALIGNBNDRY[TYPUB] := QUARTERWORDUNITS;
ALIGNBNDRY[TYPUC] := QUARTERWORDUNITS;
ALIGNBNDRY[TYPUE] := WORDUNITS;
ALIGNBNDRY[TYPUI] := WORDUNITS;
ALIGNBNDRY[TYPUJ] := WORDUNITS;
ALIGNBNDRY[TYPUK] := WORDUNITS;
ALIGNBNDRY[TYPUL] := WORDUNITS;
ALIGNBNDRY[TYPUM] := WORDUNITS;
ALIGNBNDRY[TYPUN] := WORDUNITS;
ALIGNBNDRY[TYPUP] := 0;
ALIGNBNDRY[TYPUQ] := WORDUNITS;
ALIGNBNDRY[TYPUR] := WORDUNITS;
ALIGNBNDRY[TYPUS] := WORDUNITS;
ALIGNBNDRY[TYPH] := HALFWORDUNITS;
ALIGNBNDRY[TYPQ] := QUARTERWORDUNITS;
S1SIZE[TYPUA] := S1S; S1SIZE[TYPUM] := S1S;
S1SIZE[TYPUB] := S1Q; S1SIZE[TYPUN] := S1S;
S1SIZE[TYPUC] := S1Q; S1SIZE[TYPUP] := S1S;
S1SIZE[TYPUI] := S1D; S1SIZE[TYPQ] := S1Q;
S1SIZE[TYPH] := S1H; S1SIZE[TYPUR] := S1S;
S1SIZE[TYPUJ] := S1S; S1SIZE[TYPUS] := S1D;
S1SIZE[TYPUQ] := S1D;
FUNCUNITS[TYPUA] := WORDUNITS;
FUNCUNITS[TYPUB] := WORDUNITS;
FUNCUNITS[TYPUC] := WORDUNITS;
FUNCUNITS[TYPUI] := DOUBLEWORDUNITS;
FUNCUNITS[TYPUJ] := WORDUNITS;
FUNCUNITS[TYPUK] := DOUBLEWORDUNITS;
FUNCUNITS[TYPUL] := WORDUNITS;
FUNCUNITS[TYPUM] := WORDUNITS;
FUNCUNITS[TYPUN] := WORDUNITS;
FUNCUNITS[TYPUP] := 0;
FUNCUNITS[TYPUQ] := DOUBLEWORDUNITS;
FUNCUNITS[TYPUR] := WORDUNITS;
FUNCUNITS[TYPUS] := 0; (*setch*)
FUNCUNITS[TYPH] := WORDUNITS;
FUNCUNITS[TYPQ] := WORDUNITS;
for T := FIRSTTYPE to LASTTYPE do
begin
(*peg==>*) IS_DOUBLE[T] := (T in [TYPUI, TYPUK, TYPUQ %, TYPUS\]);(*setch*)
(*27sep79*) IS_SINGLE[T] := (T in [TYPUA, TYPUJ, TYPUL, TYPUM, TYPUN, TYPUR]);
IS_INTEGER[T] := (T in [TYPQ, TYPH, TYPUI, TYPUJ, TYPUK, TYPUL]);
IS_REAL[T] := (T in [TYPUQ, TYPUR]);
IS_SIGNED_NUM[T] := (T in [TYPUI, TYPUJ, TYPUQ, TYPUR]);
end (*for T*);
SKP_NON_X[TYPUA] := XILLEGAL; SKP_NON_X[TYPUM] := XILLEGAL;
SKP_NON_X[TYPUB] := XSKP_NON_Q; SKP_NON_X[TYPUN] := XILLEGAL;
SKP_NON_X[TYPUC] := XSKP_NON_Q; SKP_NON_X[TYPUP] := XILLEGAL;
SKP_NON_X[TYPUI] := XSKP_NON_D; SKP_NON_X[TYPQ] := XSKP_NON_Q;
SKP_NON_X[TYPUK] := XSKP_NON_D;
SKP_NON_X[TYPH] := XSKP_NON_H; SKP_NON_X[TYPUR] := XILLEGAL;
SKP_NON_X[TYPUJ] := XSKP_NON_S; SKP_NON_X[TYPUS] := XILLEGAL;
SKP_NON_X[TYPUL] := XSKP_NON_S;
SKP_NON_X[TYPUQ] := XILLEGAL;
MOVMQ_N[1] := XMOV_Q_Q; MOVMQ_N[2] := XMOVMQ_2;
MOVMQ_N[3] := XMOVMQ_3; MOVMQ_N[4] := XMOVMQ_4;
MOVMQ_N[5] := XMOVMQ_5; MOVMQ_N[6] := XMOVMQ_6;
MOVMQ_N[7] := XMOVMQ_7; MOVMQ_N[8] := XMOVMQ_8;
MOVMQ_N[9] := XMOVMQ_9; MOVMQ_N[10] := XMOVMQ_10;
MOVMQ_N[11] := XMOVMQ_11; MOVMQ_N[12] := XMOVMQ_12;
MOVMQ_N[13] := XMOVMQ_13; MOVMQ_N[14] := XMOVMQ_14;
MOVMQ_N[15] := XMOVMQ_15; MOVMQ_N[16] := XMOVMQ_16;
MOVMQ_N[17] := XMOVMQ_17; MOVMQ_N[18] := XMOVMQ_18;
MOVMQ_N[19] := XMOVMQ_19; MOVMQ_N[20] := XMOVMQ_20;
MOVMQ_N[21] := XMOVMQ_21; MOVMQ_N[22] := XMOVMQ_22;
MOVMQ_N[23] := XMOVMQ_23; MOVMQ_N[24] := XMOVMQ_24;
MOVMQ_N[25] := XMOVMQ_25; MOVMQ_N[26] := XMOVMQ_26;
MOVMQ_N[27] := XMOVMQ_27; MOVMQ_N[28] := XMOVMQ_28;
MOVMQ_N[29] := XMOVMQ_29; MOVMQ_N[30] := XMOVMQ_30;
MOVMQ_N[31] := XMOVMQ_31; MOVMQ_N[32] := XMOVMQ_32;
MOVMS_N[1] := XMOV_S_S; MOVMS_N[2] := XMOVMS_2; (*ALS*)
MOVMS_N[3] := XMOVMS_3; MOVMS_N[4] := XMOVMS_4;
MOVMS_N[5] := XMOVMS_5; MOVMS_N[6] := XMOVMS_6;
MOVMS_N[7] := XMOVMS_7; MOVMS_N[8] := XMOVMS_8;
MOVMS_N[9] := XMOVMS_9; MOVMS_N[10] := XMOVMS_10;
MOVMS_N[11] := XMOVMS_11; MOVMS_N[12] := XMOVMS_12;
MOVMS_N[13] := XMOVMS_13; MOVMS_N[14] := XMOVMS_14;
MOVMS_N[15] := XMOVMS_15; MOVMS_N[16] := XMOVMS_16;
MOVMS_N[17] := XMOVMS_17; MOVMS_N[18] := XMOVMS_18;
MOVMS_N[19] := XMOVMS_19; MOVMS_N[20] := XMOVMS_20;
MOVMS_N[21] := XMOVMS_21; MOVMS_N[22] := XMOVMS_22;
MOVMS_N[23] := XMOVMS_23; MOVMS_N[24] := XMOVMS_24;
MOVMS_N[25] := XMOVMS_25; MOVMS_N[26] := XMOVMS_26;
MOVMS_N[27] := XMOVMS_27; MOVMS_N[28] := XMOVMS_28;
MOVMS_N[29] := XMOVMS_29; MOVMS_N[30] := XMOVMS_30;
MOVMS_N[31] := XMOVMS_31; MOVMS_N[32] := XMOVMS_32; (*ALS*)
MOV_X_X[TYPUA] := XMOV_S_S; MOV_X_X[TYPUM] := XMOV_S_S;
MOV_X_X[TYPUB] := XMOV_Q_Q; MOV_X_X[TYPUN] := XMOV_S_S;
MOV_X_X[TYPUC] := XMOV_Q_Q; MOV_X_X[TYPUP] := XILLEGAL;
MOV_X_X[TYPUI] := XMOV_D_D; MOV_X_X[TYPQ] := XMOV_Q_Q;
MOV_X_X[TYPUK] := XMOV_D_D;
MOV_X_X[TYPH] := XMOV_H_H; MOV_X_X[TYPUR] := XMOV_S_S;
MOV_X_X[TYPUJ] := XMOV_S_S;
MOV_X_X[TYPUL] := XMOV_S_S;
MOV_X_X[TYPUS] := MOVMS_N[NUMOFSETPARTS*2]; (*setch*)
MOV_X_X[TYPUQ] := XMOV_D_D;
ABS_X[TYPUA] := XILLEGAL; ABS_X[TYPUM] := XILLEGAL;
ABS_X[TYPUB] := XILLEGAL; ABS_X[TYPUN] := XILLEGAL;
ABS_X[TYPUC] := XILLEGAL; ABS_X[TYPUP] := XILLEGAL;
ABS_X[TYPUI] := XABS_D; ABS_X[TYPQ] := XABS_Q;
ABS_X[TYPUK] := XABS_D;
ABS_X[TYPH] := XABS_H; ABS_X[TYPUR] := XABS_S;
ABS_X[TYPUJ] := XABS_S; ABS_X[TYPUS] := XILLEGAL;
ABS_X[TYPUL] := XABS_S;
ABS_X[TYPUQ] := XABS_D;
NEG_X[TYPUA] := XILLEGAL; NEG_X[TYPUM] := XILLEGAL;
NEG_X[TYPUB] := XILLEGAL; NEG_X[TYPUN] := XILLEGAL;
NEG_X[TYPUC] := XILLEGAL; NEG_X[TYPUP] := XILLEGAL;
NEG_X[TYPUI] := XNEG_D; NEG_X[TYPQ] := XNEG_Q;
NEG_X[TYPUK] := XNEG_D;
NEG_X[TYPH] := XNEG_H; NEG_X[TYPUR] := XNEG_S;
NEG_X[TYPUJ] := XNEG_S; NEG_X[TYPUS] := XILLEGAL;
NEG_X[TYPUL] := XNEG_S;
NEG_X[TYPUQ] := XNEG_D;
FLOAT_S_X[TYPUA] := XILLEGAL;
FLOAT_S_X[TYPUB] := XILLEGAL;
FLOAT_S_X[TYPUC] := XILLEGAL;
FLOAT_S_X[TYPUI] := XFLOAT_S_D;
FLOAT_S_X[TYPUK] := XFLOAT_S_D;
FLOAT_S_X[TYPH] := XFLOAT_S_H;
FLOAT_S_X[TYPUJ] := XFLOAT_S_S;
FLOAT_S_X[TYPUL] := XFLOAT_S_S;
FLOAT_S_X[TYPUM] := XILLEGAL;
FLOAT_S_X[TYPUN] := XILLEGAL;
FLOAT_S_X[TYPUP] := XILLEGAL;
FLOAT_S_X[TYPQ] := XFLOAT_S_Q;
FLOAT_S_X[TYPUR] := XILLEGAL;
FLOAT_S_X[TYPUS] := XILLEGAL;
FLOAT_S_X[TYPUQ] := XILLEGAL;
SLR_N[0] := XSLR_0; SLR_N[1] := XSLR_1;
SLR_N[2] := XSLR_2; SLR_N[3] := XSLR_3;
SLR_N[4] := XSLR_4; SLR_N[5] := XSLR_5;
SLR_N[6] := XSLR_6; SLR_N[7] := XSLR_7;
SLR_N[8] := XSLR_8; SLR_N[9] := XSLR_9;
SLR_N[10] := XSLR_10; SLR_N[11] := XSLR_11;
SLR_N[12] := XSLR_12; SLR_N[13] := XSLR_13;
SLR_N[14] := XSLR_14; SLR_N[15] := XSLR_15;
SLR_N[16] := XSLR_16; SLR_N[17] := XSLR_17;
SLR_N[18] := XSLR_18; SLR_N[19] := XSLR_19;
SLR_N[20] := XSLR_20; SLR_N[21] := XSLR_21;
SLR_N[22] := XSLR_22; SLR_N[23] := XSLR_23;
SLR_N[24] := XSLR_24; SLR_N[25] := XSLR_25;
SLR_N[26] := XSLR_26; SLR_N[27] := XSLR_27;
SLR_N[28] := XSLR_28; SLR_N[29] := XSLR_29;
SLR_N[30] := XSLR_30; SLR_N[31] := XSLR_31;
SLRADR_N[0] := XSLRADR_0; SLRADR_N[1] := XSLRADR_1;
SLRADR_N[2] := XSLRADR_2; SLRADR_N[3] := XSLRADR_3;
SLRADR_N[4] := XSLRADR_4; SLRADR_N[5] := XSLRADR_5;
SLRADR_N[6] := XSLRADR_6; SLRADR_N[7] := XSLRADR_7;
SLRADR_N[8] := XSLRADR_8; SLRADR_N[9] := XSLRADR_9;
SLRADR_N[10] := XSLRADR_10; SLRADR_N[11] := XSLRADR_11;
SLRADR_N[12] := XSLRADR_12; SLRADR_N[13] := XSLRADR_13;
SLRADR_N[14] := XSLRADR_14; SLRADR_N[15] := XSLRADR_15;
SLRADR_N[16] := XSLRADR_16; SLRADR_N[17] := XSLRADR_17;
SLRADR_N[18] := XSLRADR_18; SLRADR_N[19] := XSLRADR_19;
SLRADR_N[20] := XSLRADR_20; SLRADR_N[21] := XSLRADR_21;
SLRADR_N[22] := XSLRADR_22; SLRADR_N[23] := XSLRADR_23;
SLRADR_N[24] := XSLRADR_24; SLRADR_N[25] := XSLRADR_25;
SLRADR_N[26] := XSLRADR_26; SLRADR_N[27] := XSLRADR_27;
SLRADR_N[28] := XSLRADR_28; SLRADR_N[29] := XSLRADR_29;
SLRADR_N[30] := XSLRADR_30; SLRADR_N[31] := XSLRADR_31;
BTRP_B_X[TYPUA] := XBTRP_B_S; BTRP_B_X[TYPUM] := XBTRP_B_S;
BTRP_B_X[TYPUB] := XBTRP_B_Q; BTRP_B_X[TYPUN] := XILLEGAL;
BTRP_B_X[TYPUC] := XBTRP_B_Q; BTRP_B_X[TYPUP] := XILLEGAL;
BTRP_B_X[TYPUI] := XBTRP_B_D; BTRP_B_X[TYPQ] := XBTRP_B_Q;
BTRP_B_X[TYPUK] := XBTRP_B_D;
BTRP_B_X[TYPH] := XBTRP_B_H; BTRP_B_X[TYPUR] := XILLEGAL;
BTRP_B_X[TYPUJ] := XBTRP_B_S; BTRP_B_X[TYPUS] := XILLEGAL;
BTRP_B_X[TYPUL] := XBTRP_B_S;
BTRP_B_X[TYPUQ] := XILLEGAL;
BTRP_N_X[0,TYPUA] := XBTRP_0_S;
BTRP_N_X[0,TYPUB] := XBTRP_0_Q;
BTRP_N_X[0,TYPUC] := XBTRP_0_Q;
BTRP_N_X[0,TYPUI] := XBTRP_0_D;
BTRP_N_X[0,TYPUK] := XBTRP_0_D;
BTRP_N_X[0,TYPH] := XBTRP_0_H;
BTRP_N_X[0,TYPUJ] := XBTRP_0_S;
BTRP_N_X[0,TYPUL] := XBTRP_0_S;
BTRP_N_X[0,TYPUM] := XBTRP_0_S;
BTRP_N_X[0,TYPUN] := XILLEGAL;
BTRP_N_X[0,TYPUP] := XILLEGAL;
BTRP_N_X[0,TYPQ] := XBTRP_0_Q;
BTRP_N_X[0,TYPUR] := XILLEGAL;
BTRP_N_X[0,TYPUS] := XILLEGAL;
BTRP_N_X[0,TYPUQ] := XILLEGAL;
BTRP_N_X[1,TYPUA] := XBTRP_1_S;
BTRP_N_X[1,TYPUB] := XBTRP_1_Q;
BTRP_N_X[1,TYPUC] := XBTRP_1_Q;
BTRP_N_X[1,TYPUI] := XBTRP_1_D;
BTRP_N_X[1,TYPUK] := XBTRP_1_D;
BTRP_N_X[1,TYPH] := XBTRP_1_H;
BTRP_N_X[1,TYPUJ] := XBTRP_1_S;
BTRP_N_X[1,TYPUL] := XBTRP_1_S;
BTRP_N_X[1,TYPUM] := XBTRP_1_S;
BTRP_N_X[1,TYPUN] := XILLEGAL;
BTRP_N_X[1,TYPUP] := XILLEGAL;
BTRP_N_X[1,TYPQ] := XBTRP_1_Q;
BTRP_N_X[1,TYPUR] := XILLEGAL;
BTRP_N_X[1,TYPUS] := XILLEGAL;
BTRP_N_X[1,TYPUQ] := XILLEGAL;
end (*INIT1*);
(** INITIALIZE_CLASS: INIT2 **)
(**)
procedure INIT2;
begin
for T1 := FIRSTTYPE to LASTTYPE do
for T2 := FIRSTTYPE to LASTTYPE do
begin
MOV_X_Y[T1, T2] := XILLEGAL;
ARITH_RESULT_TYPE[T1, T2] := ILLARITH;
COMPARE_COERCE_TYPE[T1, T2] := ILLCOMP;
end (*for*);
MOV_X_Y [TYPUA, TYPUA] := XMOV_S_S;
MOV_X_Y [TYPUA, TYPUN] := XMOV_S_S;
MOV_X_Y [TYPUA, TYPUM] := XMOV_S_S;
MOV_X_Y [TYPUB, TYPUB] := XMOV_Q_Q;
MOV_X_Y [TYPUC, TYPUC] := XMOV_Q_Q;
MOV_X_Y [TYPQ, TYPQ] := XMOV_Q_Q;
MOV_X_Y [TYPQ, TYPH] := XTRANS_Q_H;
MOV_X_Y [TYPQ, TYPUI] := XTRANS_Q_D;
MOV_X_Y [TYPQ, TYPUJ] := XTRANS_Q_S;
MOV_X_Y [TYPQ, TYPUK] := XTRANS_Q_D;
MOV_X_Y [TYPQ, TYPUL] := XTRANS_Q_S;
MOV_X_Y [TYPH, TYPQ] := XTRANS_H_Q;
MOV_X_Y [TYPH, TYPH] := XMOV_H_H;
MOV_X_Y [TYPH, TYPUI] := XTRANS_H_D;
MOV_X_Y [TYPH, TYPUJ] := XTRANS_H_S;
MOV_X_Y [TYPH, TYPUK] := XTRANS_H_D;
MOV_X_Y [TYPH, TYPUL] := XTRANS_H_S;
MOV_X_Y [TYPUI, TYPQ] := XTRANS_D_Q;
MOV_X_Y [TYPUI, TYPH] := XTRANS_D_H;
MOV_X_Y [TYPUI, TYPUI] := XMOV_D_D;
MOV_X_Y [TYPUI, TYPUJ] := XTRANS_D_S;
MOV_X_Y [TYPUI, TYPUK] := XMOV_D_D;
MOV_X_Y [TYPUI, TYPUL] := XTRANS_D_S;
MOV_X_Y [TYPUJ, TYPQ] := XTRANS_S_Q;
MOV_X_Y [TYPUJ, TYPH] := XTRANS_S_H;
MOV_X_Y [TYPUJ, TYPUI] := XTRANS_S_D;
MOV_X_Y [TYPUJ, TYPUJ] := XMOV_S_S;
MOV_X_Y [TYPUJ, TYPUK] := XTRANS_S_D;
MOV_X_Y [TYPUJ, TYPUL] := XMOV_S_S;
MOV_X_Y [TYPUJ, TYPUR] := XFX_DM_S_S;
MOV_X_Y [TYPUK, TYPQ] := XTRANS_D_Q;
MOV_X_Y [TYPUK, TYPH] := XTRANS_D_H;
MOV_X_Y [TYPUK, TYPUI] := XMOV_D_D;
MOV_X_Y [TYPUK, TYPUJ] := XTRANS_D_S;
MOV_X_Y [TYPUK, TYPUK] := XMOV_D_D;
MOV_X_Y [TYPUK, TYPUL] := XTRANS_D_S;
MOV_X_Y [TYPUL, TYPQ] := XTRANS_S_Q;
MOV_X_Y [TYPUL, TYPH] := XTRANS_S_H;
MOV_X_Y [TYPUL, TYPUI] := XTRANS_S_D;
MOV_X_Y [TYPUL, TYPUJ] := XMOV_S_S;
MOV_X_Y [TYPUL, TYPUK] := XTRANS_S_D;
MOV_X_Y [TYPUL, TYPUL] := XMOV_S_S;
MOV_X_Y [TYPUL, TYPUR] := XFX_DM_S_S;
MOV_X_Y [TYPUQ, TYPUQ] := XMOV_D_D;
MOV_X_Y [TYPUQ, TYPUR] := XFTRANS_D_S;
MOV_X_Y [TYPUR, TYPUI] := XFLOAT_S_D;
MOV_X_Y [TYPUR, TYPUJ] := XFLOAT_S_S;
MOV_X_Y [TYPUR, TYPUK] := XFLOAT_S_D;
MOV_X_Y [TYPUR, TYPUL] := XFLOAT_S_S;
MOV_X_Y [TYPUR, TYPUQ] := XFTRANS_S_D;
MOV_X_Y [TYPUR, TYPUR] := XMOV_S_S;
MOV_X_Y [TYPUS, TYPUS] := MOVMS_N[NUMOFSETPARTS*2]; (*setch*)
for T1 := TYPQ to TYPUJ do
for T2 := TYPQ to TYPUJ do
ARITH_RESULT_TYPE[T1,T2] := TYPUJ;
for T := TYPQ to TYPUI do
begin
ARITH_RESULT_TYPE[T,TYPUI] := TYPUI;
ARITH_RESULT_TYPE[TYPUI,T] := TYPUI;
end;
ARITH_RESULT_TYPE [TYPUQ,TYPUQ] := TYPUQ;
ARITH_RESULT_TYPE [TYPUQ,TYPUR] := TYPUQ;
ARITH_RESULT_TYPE [TYPUR,TYPUQ] := TYPUQ;
ARITH_RESULT_TYPE [TYPUR,TYPUR] := TYPUR;
COMPARE_COERCE_TYPE [TYPUA,TYPUM] := TYPUA;
COMPARE_COERCE_TYPE [TYPUM,TYPUA] := TYPUA;
COMPARE_COERCE_TYPE [TYPUA,TYPUN] := TYPUA;
COMPARE_COERCE_TYPE [TYPUN,TYPUA] := TYPUA;
COMPARE_COERCE_TYPE [TYPUA,TYPUA] := TYPUA;
COMPARE_COERCE_TYPE [TYPUQ,TYPUQ] := TYPUQ;
COMPARE_COERCE_TYPE [TYPUR,TYPUQ] := TYPUQ;
COMPARE_COERCE_TYPE [TYPUQ,TYPUR] := TYPUQ;
COMPARE_COERCE_TYPE [TYPUR,TYPUR] := TYPUR;
COMPARE_COERCE_TYPE [TYPQ,TYPQ] := TYPQ;
COMPARE_COERCE_TYPE [TYPQ,TYPH] := TYPH;
COMPARE_COERCE_TYPE [TYPH,TYPQ] := TYPH;
COMPARE_COERCE_TYPE [TYPH,TYPH] := TYPH;
COMPARE_COERCE_TYPE [TYPQ,TYPUJ] := TYPUJ;
COMPARE_COERCE_TYPE [TYPH,TYPUJ] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUJ,TYPQ] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUJ,TYPH] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUJ,TYPUJ] := TYPUJ;
COMPARE_COERCE_TYPE [TYPQ,TYPUL] := TYPUJ;
COMPARE_COERCE_TYPE [TYPH,TYPUL] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUL,TYPQ] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUL,TYPH] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUL,TYPUL] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUJ,TYPUL] := TYPUJ;
COMPARE_COERCE_TYPE [TYPUL,TYPUJ] := TYPUJ;
COMPARE_COERCE_TYPE [TYPQ,TYPUI] := TYPUI;
COMPARE_COERCE_TYPE [TYPH,TYPUI] := TYPUI;
COMPARE_COERCE_TYPE [TYPUJ,TYPUI] := TYPUI;
COMPARE_COERCE_TYPE [TYPUL,TYPUI] := TYPUI;
COMPARE_COERCE_TYPE [TYPUI,TYPQ] := TYPUI;
COMPARE_COERCE_TYPE [TYPUI,TYPH] := TYPUI;
COMPARE_COERCE_TYPE [TYPUI,TYPUJ] := TYPUI;
COMPARE_COERCE_TYPE [TYPUI,TYPUL] := TYPUI;
COMPARE_COERCE_TYPE [TYPUI,TYPUI] := TYPUI;
COMPARE_COERCE_TYPE [TYPQ,TYPUK] := TYPUI;
COMPARE_COERCE_TYPE [TYPH,TYPUK] := TYPUI;
COMPARE_COERCE_TYPE [TYPUJ,TYPUK] := TYPUI;
COMPARE_COERCE_TYPE [TYPUL,TYPUK] := TYPUK;
COMPARE_COERCE_TYPE [TYPUK,TYPQ] := TYPUI;
COMPARE_COERCE_TYPE [TYPUK,TYPH] := TYPUI;
COMPARE_COERCE_TYPE [TYPUK,TYPUJ] := TYPUI;
COMPARE_COERCE_TYPE [TYPUK,TYPUL] := TYPUK;
COMPARE_COERCE_TYPE [TYPUK,TYPUK] := TYPUK;
COMPARE_COERCE_TYPE [TYPUK,TYPUI] := TYPUI;
COMPARE_COERCE_TYPE [TYPUI,TYPUK] := TYPUI;
COMPARE_COERCE_TYPE [TYPUB,TYPUB] := TYPUB;
COMPARE_COERCE_TYPE [TYPUC,TYPUC] := TYPUC;
COMPARE_COERCE_TYPE [TYPUS,TYPUS] := TYPUS;
REAL_ARITH_OP [S1S, UADD] := XFADD_S;
REAL_ARITH_OP [S1D, UADD] := XFADD_D;
REAL_ARITH_OP [S1S, USUB] := XFSUB_S;
REAL_ARITH_OP [S1D, USUB] := XFSUB_D;
REAL_ARITH_OP [S1S, UMPY] := XFMULT_S;
REAL_ARITH_OP [S1D, UMPY] := XFMULT_D;
REAL_ARITH_OP [S1S, UDIV] := XFDIV_S;
REAL_ARITH_OP [S1D, UDIV] := XFDIV_D;
COMPARE_OP [S1Q, UEQU] := XSKP_EQL_Q;
COMPARE_OP [S1Q, UNEQ] := XSKP_NEQ_Q;
COMPARE_OP [S1Q, UGEQ] := XSKP_GEQ_Q;
COMPARE_OP [S1Q, UGRT] := XSKP_GTR_Q;
COMPARE_OP [S1Q, ULEQ] := XSKP_LEQ_Q;
COMPARE_OP [S1Q, ULES] := XSKP_LSS_Q;
COMPARE_OP [S1H, UEQU] := XSKP_EQL_H;
COMPARE_OP [S1H, UNEQ] := XSKP_NEQ_H;
COMPARE_OP [S1H, UGEQ] := XSKP_GEQ_H;
COMPARE_OP [S1H, UGRT] := XSKP_GTR_H;
COMPARE_OP [S1H, ULEQ] := XSKP_LEQ_H;
COMPARE_OP [S1H, ULES] := XSKP_LSS_H;
COMPARE_OP [S1S, UEQU] := XSKP_EQL_S;
COMPARE_OP [S1S, UNEQ] := XSKP_NEQ_S;
COMPARE_OP [S1S, UGEQ] := XSKP_GEQ_S;
COMPARE_OP [S1S, UGRT] := XSKP_GTR_S;
COMPARE_OP [S1S, ULEQ] := XSKP_LEQ_S;
COMPARE_OP [S1S, ULES] := XSKP_LSS_S;
COMPARE_OP [S1D, UEQU] := XSKP_EQL_D;
COMPARE_OP [S1D, UNEQ] := XSKP_NEQ_D;
COMPARE_OP [S1D, UGEQ] := XSKP_GEQ_D;
COMPARE_OP [S1D, UGRT] := XSKP_GTR_D;
COMPARE_OP [S1D, ULEQ] := XSKP_LEQ_D;
COMPARE_OP [S1D, ULES] := XSKP_LSS_D;
BLKCMP_X_Q [UEQU] := XBLCMP_EQL_Q;
BLKCMP_X_Q [UNEQ] := XBLCMP_NEQ_Q;
BLKCMP_X_Q [UGEQ] := XBLCMP_GEQ_Q;
BLKCMP_X_Q [UGRT] := XBLCMP_GTR_Q;
BLKCMP_X_Q [ULEQ] := XBLCMP_LEQ_Q;
BLKCMP_X_Q [ULES] := XBLCMP_LSS_Q;
for I := 1 to MAXLVL do
LVL_TO_S1REG[I] := MAXDSPS1REG + 1 - I;
for I := 0 to MAXPAREGM1 do
PRM_TO_S1REG[I] := I + MINPARS1REG;
for I := FIRSTS1REG to LASTS1REG do
S1REG_TO_PRM[I] := 1000000;
for I := MINPARS1REG to (MAXPAREGM1+MINPARS1REG) do
S1REG_TO_PRM[I] := I - MINPARS1REG;
ZSEGTYPE_TO_CHARS [ZIS] := 'IS ';
ZSEGTYPE_TO_CHARS [ZDS] := 'DS ';
ZSEGTYPE_TO_CHARS [ZCM] := 'CM ';
ZESDTYPE_TO_CHARS [ZST] := 'ST ';
ZESDTYPE_TO_CHARS [ZIN] := 'IN ';
ZESDTYPE_TO_CHARS [ZDN] := 'DN ';
ZESDTYPE_TO_CHARS [ZAN] := 'AN ';
ZESRTYPE_TO_CHARS [ZIR] := 'IR ';
ZESRTYPE_TO_CHARS [ZDR] := 'DR ';
ZESRTYPE_TO_CHARS [ZAR] := 'AR ';
ZESRTYPE_TO_CHARS [ZXR] := 'XR ';
ZOPR_TO_CHARS [ZPLUS] := '+ ';
ZOPR_TO_CHARS [ZMINUS] := '- ';
ZIXFLAG_TO_CHAR [ZESD] := 'D';
ZIXFLAG_TO_CHAR [ZESR] := 'R';
ZIXFLAG_TO_CHAR [ZSEG] := 'S';
for I := 0 to OPCHTSIZEM1 do
begin
OPCHASHTAB[I].OPCNAM := ' ';
end;
ENTER_OPC ('ABS ', UABS); ENTER_OPC ('ADD ', UADD);
ENTER_OPC ('SUB ', USUB); ENTER_OPC ('MPY ', UMPY);
ENTER_OPC ('DIV ', UDIV); ENTER_OPC ('ADJ ', UADJ);
ENTER_OPC ('AND ', UAND); ENTER_OPC ('BGN ', UBGN);
ENTER_OPC ('BGNB', UBGNB); ENTER_OPC ('CHKF', UCHKF);
ENTER_OPC ('CHKH', UCHKH); ENTER_OPC ('CHKL', UCHKL);
ENTER_OPC ('CHKN', UCHKN); ENTER_OPC ('CHKT', UCHKT);
ENTER_OPC ('CLAB', UCLAB); ENTER_OPC ('COMM', UCOMM);
ENTER_OPC ('CSP ', UCSP); ENTER_OPC ('CUP ', UCUP);
ENTER_OPC ('CVT ', UCVT); ENTER_OPC ('CVT2', UCVT2);
ENTER_OPC ('DEAD', UDEAD); ENTER_OPC ('DEC ', UDEC);
ENTER_OPC ('DEF ', UDEF); ENTER_OPC ('DIF ', UDIF);
ENTER_OPC ('DMD ', UDMD); ENTER_OPC ('DOA ', UDOA);
ENTER_OPC ('DSP ', UDSP); ENTER_OPC ('DUP ', UDUP);
ENTER_OPC ('END ', UEND); ENTER_OPC ('ENDB', UENDB);
ENTER_OPC ('ENT ', UENT); ENTER_OPC ('EXPP', UEXPP);
ENTER_OPC ('EXPV', UEXPV); ENTER_OPC ('FJP ', UFJP);
ENTER_OPC ('ICUP', UICUP); ENTER_OPC ('EQU ', UEQU);
ENTER_OPC ('NEQ ', UNEQ); ENTER_OPC ('GEQ ', UGEQ);
ENTER_OPC ('GOOB', UGOOB);
ENTER_OPC ('GRT ', UGRT); ENTER_OPC ('LEQ ', ULEQ);
ENTER_OPC ('LES ', ULES); ENTER_OPC ('IEQU', UIEQU);
ENTER_OPC ('INEQ', UINEQ); ENTER_OPC ('IGEQ', UIGEQ);
ENTER_OPC ('IGRT', UIGRT); ENTER_OPC ('ILEQ', UILEQ);
ENTER_OPC ('ILES', UILES); ENTER_OPC ('ILOD', UILOD);
ENTER_OPC ('MOV ', UMOV); ENTER_OPC ('IMPP', UIMPP);
ENTER_OPC ('IMPV', UIMPV); ENTER_OPC ('INC ', UINC);
ENTER_OPC ('INN ', UINN); ENTER_OPC ('INST', UINST);
ENTER_OPC ('INT ', UINT); ENTER_OPC ('IOR ', UIOR);
ENTER_OPC ('ISTR', UISTR); ENTER_OPC ('IXA ', UIXA);
ENTER_OPC ('LAB ', ULAB); ENTER_OPC ('LCA ', ULCA);
ENTER_OPC ('LDA ', ULDA); ENTER_OPC ('LDC ', ULDC);
ENTER_OPC ('LDP ', ULDP); ENTER_OPC ('LEX ', ULEX);
ENTER_OPC ('LIVE', ULIVE); ENTER_OPC ('LOC ', ULOC);
ENTER_OPC ('LOD ', ULOD); ENTER_OPC ('MDEF', UMDEF);
ENTER_OPC ('MOD ', UMOD); ENTER_OPC ('MST ', UMST);
ENTER_OPC ('MUS ', UMUS); ENTER_OPC ('NEG ', UNEG);
ENTER_OPC ('NEW ', UNEW); ENTER_OPC ('NOT ', UNOT);
ENTER_OPC ('NSTR', UNSTR); ENTER_OPC ('ODD ', UODD);
ENTER_OPC ('OPTN', UOPTN); ENTER_OPC ('PAR ', UPAR);
ENTER_OPC ('PLEX', UPLEX); ENTER_OPC ('PLOD', UPLOD);
ENTER_OPC ('PSTR', UPSTR); ENTER_OPC ('RET ', URET);
ENTER_OPC ('RND ', URND); ENTER_OPC ('SDEF', USDEF);
ENTER_OPC ('SGS ', USGS); ENTER_OPC ('SQR ', USQR);
ENTER_OPC ('STP ', USTP); ENTER_OPC ('STR ', USTR);
ENTER_OPC ('SWP ', USWP); ENTER_OPC ('SYM ', USYM);
ENTER_OPC ('TJP ', UTJP); ENTER_OPC ('TYP ', UTYP);
ENTER_OPC ('TYP2', UTYP2); ENTER_OPC ('UJP ', UUJP);
ENTER_OPC ('UNI ', UUNI); ENTER_OPC ('UNK ', UUNK);
ENTER_OPC ('XJP ', UXJP); ENTER_OPC ('XOR ', UXOR);
end (*INIT2*);
(** INITIALIZE_CLASS: INIT3 **)
(**)
procedure INIT3;
begin
for I := 0 to CSPHTSIZEM1 do
begin
CSPHASHTAB[I].CSPNAM.NAM := ' ';
CSPHASHTAB[I].CSPNAM.LEN := 1;
end;
ENTER_CSP ('ATN', QATN); ENTER_CSP ('EXP', QEXP);
ENTER_CSP ('SIN', QSIN); ENTER_CSP ('COS', QCOS);
ENTER_CSP ('LOG', QLOG); ENTER_CSP ('SQT', QSQT);
ENTER_CSP ('CLK', QCLK); ENTER_CSP ('XIT', QXIT);
ENTER_CSP ('TRP', QTRP); ENTER_CSP ('GET', QGET);
ENTER_CSP ('PUT', QPUT); ENTER_CSP ('RLN', QRLN);
ENTER_CSP ('WLN', QWLN); ENTER_CSP ('RES', QRES);
ENTER_CSP ('REW', QREW); ENTER_CSP ('RDC', QRDC);
ENTER_CSP ('RDI', QRDI); ENTER_CSP ('RDR', QRDR);
ENTER_CSP ('RDS', QRDS); ENTER_CSP ('WRC', QWRC);
ENTER_CSP ('RDB', QRDB); ENTER_CSP ('WRB', QWRB);
ENTER_CSP ('WRI', QWRI); ENTER_CSP ('WRR', QWRR);
ENTER_CSP ('WRS', QWRS); ENTER_CSP ('ELN', QELN);
ENTER_CSP ('EOF', QEOF); ENTER_CSP ('SIO', QSIO);
ENTER_CSP ('EIO', QEIO); ENTER_CSP ('NEW', QNEW);
ENTER_CSP ('SAV', QSAV); ENTER_CSP ('RST', QRST);
ENTER_CSP ('RND', QRND); (*ROUND*)
for S1OP := FIRSTS1OP to LASTS1OP do
REVERSE_OP[S1OP] := XILLEGAL;
REVERSE_OP[XADD_S] := XADD_S;
REVERSE_OP[XADD_D] := XADD_D;
REVERSE_OP[XAND_Q] := XAND_Q;
REVERSE_OP[XAND_D] := XAND_D;
REVERSE_OP[XAND_TC_D] := XAND_CT_D;
REVERSE_OP[XAND_CT_D] := XAND_TC_D;
REVERSE_OP[XDSKP_EQL] := XDSKP_EQL; (*25JUN79 PTZ...*)
REVERSE_OP[XDSKP_NEQ] := XDSKP_NEQ;
REVERSE_OP[XDSKP_GEQ] := XDSKP_LEQ;
REVERSE_OP[XDSKP_GTR] := XDSKP_LSS;
REVERSE_OP[XDSKP_LEQ] := XDSKP_GEQ;
REVERSE_OP[XDSKP_LSS] := XDSKP_GTR; (*...25JUN79 PTZ*)
REVERSE_OP[XFADD_S] := XFADD_S;
REVERSE_OP[XFADD_D] := XFADD_D;
REVERSE_OP[XFSUB_S] := XFSUBV_S;
REVERSE_OP[XFSUBV_S] := XFSUB_S;
REVERSE_OP[XFSUB_D] := XFSUBV_D;
REVERSE_OP[XFSUBV_D] := XFSUB_D;
REVERSE_OP[XFMULT_S] := XFMULT_S;
REVERSE_OP[XFMULT_D] := XFMULT_D;
REVERSE_OP[XFDIV_S] := XFDIVV_S;
REVERSE_OP[XFDIVV_S] := XFDIV_S;
REVERSE_OP[XFDIV_D] := XFDIVV_D;
REVERSE_OP[XFDIVV_D] := XFDIV_D;
REVERSE_OP[XISKP_EQL] := XISKP_EQL; (*25JUN79 PTZ...*)
REVERSE_OP[XISKP_NEQ] := XISKP_NEQ;
REVERSE_OP[XISKP_GEQ] := XISKP_LEQ;
REVERSE_OP[XISKP_GTR] := XISKP_LSS;
REVERSE_OP[XISKP_LEQ] := XISKP_GEQ;
REVERSE_OP[XISKP_LSS] := XISKP_GTR; (*...25JUN79 PTZ*)
REVERSE_OP[XMULT_S] := XMULT_S;
REVERSE_OP[XMULT_D] := XMULT_D;
REVERSE_OP[XNOP] := XNOP;
REVERSE_OP[XOR_Q] := XOR_Q;
REVERSE_OP[XOR_D] := XOR_D;
REVERSE_OP[XQUO_S] := XQUOV_S;
REVERSE_OP[XQUOV_S] := XQUO_S;
REVERSE_OP[XQUO_D] := XQUOV_D;
REVERSE_OP[XQUOV_D] := XQUO_D;
REVERSE_OP[XREM_S] := XREMV_S;
REVERSE_OP[XREMV_S] := XREM_S;
REVERSE_OP[XREM_D] := XREMV_D;
REVERSE_OP[XREMV_D] := XREM_D;
REVERSE_OP[XSHF_LF_D] := XSHFV_LF_D;
REVERSE_OP[XSHFV_LF_D] := XSHF_LF_D;
REVERSE_OP[XSHFA_LF_S] := XSHFAV_LF_S;
REVERSE_OP[XSHFAV_LF_S] := XSHFA_LF_S;
REVERSE_OP[XSKP_EQL_Q] := XSKP_EQL_Q; (*unused at this time 25JUN79 PTZ...*)
REVERSE_OP[XSKP_NEQ_Q] := XSKP_NEQ_Q;
REVERSE_OP[XSKP_GEQ_Q] := XSKP_LEQ_Q;
REVERSE_OP[XSKP_GTR_Q] := XSKP_LSS_Q;
REVERSE_OP[XSKP_LEQ_Q] := XSKP_GEQ_Q;
REVERSE_OP[XSKP_LSS_Q] := XSKP_GTR_Q;
REVERSE_OP[XSKP_EQL_H] := XSKP_EQL_H;
REVERSE_OP[XSKP_NEQ_H] := XSKP_NEQ_H;
REVERSE_OP[XSKP_GEQ_H] := XSKP_LEQ_H;
REVERSE_OP[XSKP_GTR_H] := XSKP_LSS_H;
REVERSE_OP[XSKP_LEQ_H] := XSKP_GEQ_H;
REVERSE_OP[XSKP_LSS_H] := XSKP_GTR_H;
REVERSE_OP[XSKP_EQL_S] := XSKP_EQL_S;
REVERSE_OP[XSKP_NEQ_S] := XSKP_NEQ_S;
REVERSE_OP[XSKP_GEQ_S] := XSKP_LEQ_S;
REVERSE_OP[XSKP_GTR_S] := XSKP_LSS_S;
REVERSE_OP[XSKP_LEQ_S] := XSKP_GEQ_S;
REVERSE_OP[XSKP_LSS_S] := XSKP_GTR_S;
REVERSE_OP[XSKP_EQL_D] := XSKP_EQL_D;
REVERSE_OP[XSKP_NEQ_D] := XSKP_NEQ_D;
REVERSE_OP[XSKP_GEQ_D] := XSKP_LEQ_D;
REVERSE_OP[XSKP_GTR_D] := XSKP_LSS_D;
REVERSE_OP[XSKP_LEQ_D] := XSKP_GEQ_D;
REVERSE_OP[XSKP_LSS_D] := XSKP_GTR_D;
REVERSE_OP[XSKP_NON_Q] := XSKP_NON_Q;
REVERSE_OP[XSKP_NON_H] := XSKP_NON_H;
REVERSE_OP[XSKP_NON_S] := XSKP_NON_S;
REVERSE_OP[XSKP_NON_D] := XSKP_NON_D;
REVERSE_OP[XSKP_ANY_Q] := XSKP_ANY_Q;
REVERSE_OP[XSKP_ANY_H] := XSKP_ANY_H;
REVERSE_OP[XSKP_ANY_S] := XSKP_ANY_S;
REVERSE_OP[XSKP_ANY_D] := XSKP_ANY_D; (*...unused at this time 25JUN79 PTZ*)
REVERSE_OP[XSUB_S] := XSUBV_S;
REVERSE_OP[XSUBV_S] := XSUB_S;
REVERSE_OP[XSUB_D] := XSUBV_D;
REVERSE_OP[XSUBV_D] := XSUB_D;
REVERSE_OP[XXOR_Q] := XXOR_Q;
OPFORMAT [XILLEGAL] := VFAKEOP;
OPFORMAT [XPLOC] := VFAKEOP;
OPFORMAT [XS1LOC] := VFAKEOP;
OPFORMAT [XFREEREG] := VFAKEOP; (*PBK*)
OPFORMAT [XABS_Q] := VXOP;
OPFORMAT [XABS_H] := VXOP;
OPFORMAT [XABS_S] := VXOP;
OPFORMAT [XABS_D] := VXOP;
OPFORMAT [XADD_S] := VTOP;
OPFORMAT [XADD_D] := VTOP;
OPFORMAT [XADJSP_UP] := VXOP;
OPFORMAT [XADJSP_DN] := VXOP;
OPFORMAT [XALLOC_1] := VXOP;
OPFORMAT [XAND_Q] := VTOP;
OPFORMAT [XAND_D] := VTOP;
OPFORMAT [XAND_TC_D] := VTOP;
OPFORMAT [XAND_CT_D] := VTOP;
OPFORMAT [XBLCMP_EQL_Q] := VXOP;
OPFORMAT [XBLCMP_NEQ_Q] := VXOP;
OPFORMAT [XBLCMP_GEQ_Q] := VXOP;
OPFORMAT [XBLCMP_GTR_Q] := VXOP;
OPFORMAT [XBLCMP_LEQ_Q] := VXOP;
OPFORMAT [XBLCMP_LSS_Q] := VXOP;
OPFORMAT [XBLKMOV] := VXOP;
OPFORMAT [XBTRP_B_Q] := VXOP;
OPFORMAT [XBTRP_B_H] := VXOP;
OPFORMAT [XBTRP_B_S] := VXOP;
OPFORMAT [XBTRP_B_D] := VXOP;
OPFORMAT [XBTRP_M1_Q] := VXOP;
OPFORMAT [XBTRP_M1_H] := VXOP;
OPFORMAT [XBTRP_M1_S] := VXOP;
OPFORMAT [XBTRP_M1_D] := VXOP;
OPFORMAT [XBTRP_0_Q] := VXOP;
OPFORMAT [XBTRP_0_H] := VXOP;
OPFORMAT [XBTRP_0_S] := VXOP;
OPFORMAT [XBTRP_0_D] := VXOP;
OPFORMAT [XBTRP_1_Q] := VXOP;
OPFORMAT [XBTRP_1_H] := VXOP;
OPFORMAT [XBTRP_1_S] := VXOP;
OPFORMAT [XBTRP_1_D] := VXOP;
OPFORMAT [XDEC_S] := VXOP;
OPFORMAT [XDJMPA] := VJOP; (*25JUN79 PTZ...*)
OPFORMAT [XDSKP_EQL] := VSOP;
OPFORMAT [XDSKP_NEQ] := VSOP;
OPFORMAT [XDSKP_GEQ] := VSOP;
OPFORMAT [XDSKP_GTR] := VSOP;
OPFORMAT [XDSKP_LEQ] := VSOP;
OPFORMAT [XDSKP_LSS] := VSOP; (*...25JUN79 PTZ*)
OPFORMAT [XFX_DM_S_S] := VXOP;
OPFORMAT [XFX_DM_S_D] := VXOP;
OPFORMAT [XFX_FL_S_S] := VXOP;
OPFORMAT [XFLOAT_S_Q] := VXOP;
OPFORMAT [XFLOAT_S_H] := VXOP;
OPFORMAT [XFLOAT_S_S] := VXOP;
OPFORMAT [XFLOAT_S_D] := VXOP;
OPFORMAT [XFADD_S] := VTOP;
OPFORMAT [XFADD_D] := VTOP;
OPFORMAT [XFSUB_S] := VTOP;
OPFORMAT [XFSUBV_S] := VTOP;
OPFORMAT [XFSUB_D] := VTOP;
OPFORMAT [XFSUBV_D] := VTOP;
OPFORMAT [XFMULT_S] := VTOP;
OPFORMAT [XFMULT_D] := VTOP;
OPFORMAT [XFDIV_S] := VTOP;
OPFORMAT [XFDIVV_S] := VTOP;
OPFORMAT [XFDIV_D] := VTOP;
OPFORMAT [XFDIVV_D] := VTOP;
OPFORMAT [XFTRANS_S_D] := VXOP;
OPFORMAT [XFTRANS_D_S] := VXOP;
OPFORMAT [XHALT] := VJOP; (*BNDTRPKLU*)
OPFORMAT [XIJMPA] := VJOP; (*25JUN79 PTZ*)
OPFORMAT [XINC_S] := VXOP;
OPFORMAT [XISKP_EQL] := VSOP; (*25JUN79 PTZ...*)
OPFORMAT [XISKP_NEQ] := VSOP;
OPFORMAT [XISKP_GEQ] := VSOP;
OPFORMAT [XISKP_GTR] := VSOP;
OPFORMAT [XISKP_LEQ] := VSOP;
OPFORMAT [XISKP_LSS] := VSOP; (*...25JUN79 PTZ*)
OPFORMAT [XJMPA] := VJOP;
OPFORMAT [XJMPZ_EQL_Q] := VJOP;
OPFORMAT [XJMPZ_NEQ_Q] := VJOP; (* als/peg 19jul79 *)
OPFORMAT [XJSR] := VJOP;
OPFORMAT [XMOV_A] := VXOP;
OPFORMAT [XMOV_Q_Q] := VXOP;
OPFORMAT [XMOV_Q_H] := VXOP;
OPFORMAT [XMOV_H_Q] := VXOP;
OPFORMAT [XMOV_H_H] := VXOP;
OPFORMAT [XMOV_Q_S] := VXOP;
OPFORMAT [XMOV_H_S] := VXOP;
OPFORMAT [XMOV_S_Q] := VXOP;
OPFORMAT [XMOV_S_H] := VXOP;
OPFORMAT [XMOV_S_S] := VXOP;
OPFORMAT [XMOV_Q_D] := VXOP;
OPFORMAT [XMOV_H_D] := VXOP;
OPFORMAT [XMOV_S_D] := VXOP;
OPFORMAT [XMOV_D_Q] := VXOP;
OPFORMAT [XMOV_D_H] := VXOP;
OPFORMAT [XMOV_D_S] := VXOP;
OPFORMAT [XMOV_D_D] := VXOP;
OPFORMAT [XMOVMQ_2] := VXOP;
OPFORMAT [XMOVMQ_3] := VXOP;
OPFORMAT [XMOVMQ_4] := VXOP;
OPFORMAT [XMOVMQ_5] := VXOP;
OPFORMAT [XMOVMQ_6] := VXOP;
OPFORMAT [XMOVMQ_7] := VXOP;
OPFORMAT [XMOVMQ_8] := VXOP;
OPFORMAT [XMOVMQ_9] := VXOP;
OPFORMAT [XMOVMQ_10] := VXOP;
OPFORMAT [XMOVMQ_11] := VXOP;
OPFORMAT [XMOVMQ_12] := VXOP;
OPFORMAT [XMOVMQ_13] := VXOP;
OPFORMAT [XMOVMQ_14] := VXOP;
OPFORMAT [XMOVMQ_15] := VXOP;
OPFORMAT [XMOVMQ_16] := VXOP;
OPFORMAT [XMOVMQ_17] := VXOP;
OPFORMAT [XMOVMQ_18] := VXOP;
OPFORMAT [XMOVMQ_19] := VXOP;
OPFORMAT [XMOVMQ_20] := VXOP;
OPFORMAT [XMOVMQ_21] := VXOP;
OPFORMAT [XMOVMQ_22] := VXOP;
OPFORMAT [XMOVMQ_23] := VXOP;
OPFORMAT [XMOVMQ_24] := VXOP;
OPFORMAT [XMOVMQ_25] := VXOP;
OPFORMAT [XMOVMQ_26] := VXOP;
OPFORMAT [XMOVMQ_27] := VXOP;
OPFORMAT [XMOVMQ_28] := VXOP;
OPFORMAT [XMOVMQ_29] := VXOP;
OPFORMAT [XMOVMQ_30] := VXOP;
OPFORMAT [XMOVMQ_31] := VXOP;
OPFORMAT [XMOVMQ_32] := VXOP;
OPFORMAT [XMOVMQ_64] := VXOP;
OPFORMAT [XMOVMQ_128] := VXOP;
OPFORMAT [XMOVMS_2] := VXOP; (*ALS*)
OPFORMAT [XMOVMS_3] := VXOP;
OPFORMAT [XMOVMS_4] := VXOP;
OPFORMAT [XMOVMS_5] := VXOP;
OPFORMAT [XMOVMS_6] := VXOP;
OPFORMAT [XMOVMS_7] := VXOP;
OPFORMAT [XMOVMS_8] := VXOP;
OPFORMAT [XMOVMS_9] := VXOP;
OPFORMAT [XMOVMS_10] := VXOP;
OPFORMAT [XMOVMS_11] := VXOP;
OPFORMAT [XMOVMS_12] := VXOP;
OPFORMAT [XMOVMS_13] := VXOP;
OPFORMAT [XMOVMS_14] := VXOP;
OPFORMAT [XMOVMS_15] := VXOP;
OPFORMAT [XMOVMS_16] := VXOP;
OPFORMAT [XMOVMS_17] := VXOP;
OPFORMAT [XMOVMS_18] := VXOP;
OPFORMAT [XMOVMS_19] := VXOP;
OPFORMAT [XMOVMS_20] := VXOP;
OPFORMAT [XMOVMS_21] := VXOP;
OPFORMAT [XMOVMS_22] := VXOP;
OPFORMAT [XMOVMS_23] := VXOP;
OPFORMAT [XMOVMS_24] := VXOP;
OPFORMAT [XMOVMS_25] := VXOP;
OPFORMAT [XMOVMS_26] := VXOP;
OPFORMAT [XMOVMS_27] := VXOP;
OPFORMAT [XMOVMS_28] := VXOP;
OPFORMAT [XMOVMS_29] := VXOP;
OPFORMAT [XMOVMS_30] := VXOP;
OPFORMAT [XMOVMS_31] := VXOP;
OPFORMAT [XMOVMS_32] := VXOP; (*ALS*)
OPFORMAT [XMULT_S] := VTOP;
OPFORMAT [XMULT_D] := VTOP;
OPFORMAT [XDIV_S] := VTOP; (* als/peg 18jul79 *)
OPFORMAT [XNEG_Q] := VXOP;
OPFORMAT [XNEG_H] := VXOP;
OPFORMAT [XNEG_S] := VXOP;
OPFORMAT [XNEG_D] := VXOP;
OPFORMAT [XNOP] := VXOP;
OPFORMAT [XOR_Q] := VTOP;
OPFORMAT [XOR_D] := VTOP;
OPFORMAT [XQUO_S] := VTOP;
OPFORMAT [XQUOV_S] := VTOP;
OPFORMAT [XQUO_D] := VTOP;
OPFORMAT [XQUOV_D] := VTOP;
OPFORMAT [XREM_S] := VTOP;
OPFORMAT [XREMV_S] := VTOP;
OPFORMAT [XREM_D] := VTOP;
OPFORMAT [XREMV_D] := VTOP;
OPFORMAT [XRETSR] := VXOP;
OPFORMAT [XSHF_LF_D] := VTOP;
OPFORMAT [XSHFV_LF_D] := VTOP;
OPFORMAT [XSHFA_LF_S] := VTOP;
OPFORMAT [XSHFAV_LF_S] := VTOP;
OPFORMAT [XSKP_EQL_Q] := VSOP;
OPFORMAT [XSKP_NEQ_Q] := VSOP;
OPFORMAT [XSKP_GEQ_Q] := VSOP;
OPFORMAT [XSKP_GTR_Q] := VSOP;
OPFORMAT [XSKP_LEQ_Q] := VSOP;
OPFORMAT [XSKP_LSS_Q] := VSOP;
OPFORMAT [XSKP_EQL_H] := VSOP;
OPFORMAT [XSKP_NEQ_H] := VSOP;
OPFORMAT [XSKP_GEQ_H] := VSOP;
OPFORMAT [XSKP_GTR_H] := VSOP;
OPFORMAT [XSKP_LEQ_H] := VSOP;
OPFORMAT [XSKP_LSS_H] := VSOP;
OPFORMAT [XSKP_EQL_S] := VSOP;
OPFORMAT [XSKP_NEQ_S] := VSOP;
OPFORMAT [XSKP_GEQ_S] := VSOP;
OPFORMAT [XSKP_GTR_S] := VSOP;
OPFORMAT [XSKP_LEQ_S] := VSOP;
OPFORMAT [XSKP_LSS_S] := VSOP;
OPFORMAT [XSKP_EQL_D] := VSOP;
OPFORMAT [XSKP_NEQ_D] := VSOP;
OPFORMAT [XSKP_GEQ_D] := VSOP;
OPFORMAT [XSKP_GTR_D] := VSOP;
OPFORMAT [XSKP_LEQ_D] := VSOP;
OPFORMAT [XSKP_LSS_D] := VSOP;
OPFORMAT [XSKP_NON_Q] := VSOP;
OPFORMAT [XSKP_NON_H] := VSOP;
OPFORMAT [XSKP_NON_S] := VSOP;
OPFORMAT [XSKP_NON_D] := VSOP;
OPFORMAT [XSKP_ANY_Q] := VSOP;
OPFORMAT [XSKP_ANY_H] := VSOP;
OPFORMAT [XSKP_ANY_S] := VSOP;
OPFORMAT [XSKP_ANY_D] := VSOP;
OPFORMAT [XSLR_0] := VXOP;
OPFORMAT [XSLR_1] := VXOP;
OPFORMAT [XSLR_2] := VXOP;
OPFORMAT [XSLR_3] := VXOP;
OPFORMAT [XSLR_4] := VXOP;
OPFORMAT [XSLR_5] := VXOP;
OPFORMAT [XSLR_6] := VXOP;
OPFORMAT [XSLR_7] := VXOP;
OPFORMAT [XSLR_8] := VXOP;
OPFORMAT [XSLR_9] := VXOP;
OPFORMAT [XSLR_10] := VXOP;
OPFORMAT [XSLR_11] := VXOP;
OPFORMAT [XSLR_12] := VXOP;
OPFORMAT [XSLR_13] := VXOP;
OPFORMAT [XSLR_14] := VXOP;
OPFORMAT [XSLR_15] := VXOP;
OPFORMAT [XSLR_16] := VXOP;
OPFORMAT [XSLR_17] := VXOP;
OPFORMAT [XSLR_18] := VXOP;
OPFORMAT [XSLR_19] := VXOP;
OPFORMAT [XSLR_20] := VXOP;
OPFORMAT [XSLR_21] := VXOP;
OPFORMAT [XSLR_22] := VXOP;
OPFORMAT [XSLR_23] := VXOP;
OPFORMAT [XSLR_24] := VXOP;
OPFORMAT [XSLR_25] := VXOP;
OPFORMAT [XSLR_26] := VXOP;
OPFORMAT [XSLR_27] := VXOP;
OPFORMAT [XSLR_28] := VXOP;
OPFORMAT [XSLR_29] := VXOP;
OPFORMAT [XSLR_30] := VXOP;
OPFORMAT [XSLR_31] := VXOP;
OPFORMAT [XSLRADR_0] := VXOP;
OPFORMAT [XSLRADR_1] := VXOP;
OPFORMAT [XSLRADR_2] := VXOP;
OPFORMAT [XSLRADR_3] := VXOP;
OPFORMAT [XSLRADR_4] := VXOP;
OPFORMAT [XSLRADR_5] := VXOP;
OPFORMAT [XSLRADR_6] := VXOP;
OPFORMAT [XSLRADR_7] := VXOP;
OPFORMAT [XSLRADR_8] := VXOP;
OPFORMAT [XSLRADR_9] := VXOP;
OPFORMAT [XSLRADR_10] := VXOP;
OPFORMAT [XSLRADR_11] := VXOP;
OPFORMAT [XSLRADR_12] := VXOP;
OPFORMAT [XSLRADR_13] := VXOP;
OPFORMAT [XSLRADR_14] := VXOP;
OPFORMAT [XSLRADR_15] := VXOP;
OPFORMAT [XSLRADR_16] := VXOP;
OPFORMAT [XSLRADR_17] := VXOP;
OPFORMAT [XSLRADR_18] := VXOP;
OPFORMAT [XSLRADR_19] := VXOP;
OPFORMAT [XSLRADR_20] := VXOP;
OPFORMAT [XSLRADR_21] := VXOP;
OPFORMAT [XSLRADR_22] := VXOP;
OPFORMAT [XSLRADR_23] := VXOP;
OPFORMAT [XSLRADR_24] := VXOP;
OPFORMAT [XSLRADR_25] := VXOP;
OPFORMAT [XSLRADR_26] := VXOP;
OPFORMAT [XSLRADR_27] := VXOP;
OPFORMAT [XSLRADR_28] := VXOP;
OPFORMAT [XSLRADR_29] := VXOP;
OPFORMAT [XSLRADR_30] := VXOP;
OPFORMAT [XSLRADR_31] := VXOP;
OPFORMAT [XSUB_S] := VTOP;
OPFORMAT [XSUBV_S] := VTOP;
OPFORMAT [XSUB_D] := VTOP;
OPFORMAT [XSUBV_D] := VTOP;
OPFORMAT [XTRANS_Q_Q] := VXOP;
OPFORMAT [XTRANS_Q_H] := VXOP;
OPFORMAT [XTRANS_H_Q] := VXOP;
OPFORMAT [XTRANS_H_H] := VXOP;
OPFORMAT [XTRANS_Q_S] := VXOP;
OPFORMAT [XTRANS_H_S] := VXOP;
OPFORMAT [XTRANS_S_Q] := VXOP;
OPFORMAT [XTRANS_S_H] := VXOP;
OPFORMAT [XTRANS_S_S] := VXOP;
OPFORMAT [XTRANS_Q_D] := VXOP;
OPFORMAT [XTRANS_H_D] := VXOP;
OPFORMAT [XTRANS_S_D] := VXOP;
OPFORMAT [XTRANS_D_Q] := VXOP;
OPFORMAT [XTRANS_D_H] := VXOP;
OPFORMAT [XTRANS_D_S] := VXOP;
OPFORMAT [XTRANS_D_D] := VXOP;
OPFORMAT [XXOR_Q] := VTOP;
end (*INIT3*);
(** INITIALIZE_CLASS: INIT4 **)
(**)
procedure INIT4;
begin
S1MNEM [XILLEGAL] := 'ILLEGAL ';
S1MNEM [XPLOC] := 'ULOC ';
S1MNEM [XS1LOC] := 'S1LOC ';
S1MNEM [XFREEREG] := 'FREEREG '; (*PBK*)
(* START S1MNEM MARKER FOR OPS.PAS *)
S1MNEM [XABS_Q] := 'ABS.Q ';
S1MNEM [XABS_H] := 'ABS.H ';
S1MNEM [XABS_S] := 'ABS.S ';
S1MNEM [XABS_D] := 'ABS.D ';
S1MNEM [XADD_S] := 'ADD.S ';
S1MNEM [XADD_D] := 'ADD.D ';
S1MNEM [XADJSP_UP] := 'ADJSP.UP ';
S1MNEM [XADJSP_DN] := 'ADJSP.DN ';
S1MNEM [XALLOC_1] := 'ALLOC.1 ';
S1MNEM [XAND_Q] := 'AND.Q ';
S1MNEM [XAND_D] := 'AND.D ';
S1MNEM [XAND_TC_D] := 'ANDTC.D ';
S1MNEM [XAND_CT_D] := 'ANDCT.D ';
S1MNEM [XBLCMP_EQL_Q] := 'BLKCMP.EQL.Q ';
S1MNEM [XBLCMP_NEQ_Q] := 'BLKCMP.NEQ.Q ';
S1MNEM [XBLCMP_GEQ_Q] := 'BLKCMP.GEQ.Q ';
S1MNEM [XBLCMP_GTR_Q] := 'BLKCMP.GTR.Q ';
S1MNEM [XBLCMP_LEQ_Q] := 'BLKCMP.LEQ.Q ';
S1MNEM [XBLCMP_LSS_Q] := 'BLKCMP.LSS.Q ';
S1MNEM [XBLKMOV] := 'BLKMOV ';
S1MNEM [XBTRP_B_Q] := 'BNDTRP.B.Q ';
S1MNEM [XBTRP_B_H] := 'BNDTRP.B.H ';
S1MNEM [XBTRP_B_S] := 'BNDTRP.B.S ';
S1MNEM [XBTRP_B_D] := 'BNDTRP.B.D ';
S1MNEM [XBTRP_M1_Q] := 'BNDTRP.M1.Q ';
S1MNEM [XBTRP_M1_H] := 'BNDTRP.M1.H ';
S1MNEM [XBTRP_M1_S] := 'BNDTRP.M1.S ';
S1MNEM [XBTRP_M1_D] := 'BNDTRP.M1.D ';
S1MNEM [XBTRP_0_Q] := 'BNDTRP.0.Q ';
S1MNEM [XBTRP_0_H] := 'BNDTRP.0.H ';
S1MNEM [XBTRP_0_S] := 'BNDTRP.0.S ';
S1MNEM [XBTRP_0_D] := 'BNDTRP.0.D ';
S1MNEM [XBTRP_1_Q] := 'BNDTRP.1.Q ';
S1MNEM [XBTRP_1_H] := 'BNDTRP.1.H ';
S1MNEM [XBTRP_1_S] := 'BNDTRP.1.S ';
S1MNEM [XBTRP_1_D] := 'BNDTRP.1.D ';
S1MNEM [XDEC_S] := 'DEC.S ';
S1MNEM [XDJMPA] := 'DJMPA ';
S1MNEM [XDSKP_EQL] := 'DSKP.EQL ';
S1MNEM [XDSKP_NEQ] := 'DSKP.NEQ ';
S1MNEM [XDSKP_GEQ] := 'DSKP.GEQ ';
S1MNEM [XDSKP_GTR] := 'DSKP.GTR ';
S1MNEM [XDSKP_LEQ] := 'DSKP.LEQ ';
S1MNEM [XDSKP_LSS] := 'DSKP.LSS ';
S1MNEM [XFX_DM_S_S] := 'FIX.DM.S.S ';
S1MNEM [XFX_DM_S_D] := 'FIX.DM.S.D ';
S1MNEM [XFX_FL_S_S] := 'FIX.FL.S.S ';
S1MNEM [XFLOAT_S_Q] := 'FLOAT.S.Q ';
S1MNEM [XFLOAT_S_H] := 'FLOAT.S.H ';
S1MNEM [XFLOAT_S_S] := 'FLOAT.S.S ';
S1MNEM [XFLOAT_S_D] := 'FLOAT.S.D ';
S1MNEM [XFADD_S] := 'FADD.S ';
S1MNEM [XFADD_D] := 'FADD.D ';
S1MNEM [XFSUB_S] := 'FSUB.S ';
S1MNEM [XFSUBV_S] := 'FSUBV.S ';
S1MNEM [XFSUB_D] := 'FSUB.D ';
S1MNEM [XFSUBV_D] := 'FSUBV.D ';
S1MNEM [XFMULT_S] := 'FMULT.S ';
S1MNEM [XFMULT_D] := 'FMULT.D ';
S1MNEM [XFDIV_S] := 'FDIV.S ';
S1MNEM [XFDIVV_S] := 'FDIVV.S ';
S1MNEM [XFDIV_D] := 'FDIV.D ';
S1MNEM [XFDIVV_D] := 'FDIVV.D ';
S1MNEM [XFTRANS_S_D] := 'FTRANS.S.D ';
S1MNEM [XFTRANS_D_S] := 'FTRANS.D.S ';
S1MNEM [XHALT] := 'HALT ';
S1MNEM [XIJMPA] := 'IJMPA ';
S1MNEM [XINC_S] := 'INC.S ';
S1MNEM [XISKP_EQL] := 'ISKP.EQL ';
S1MNEM [XISKP_NEQ] := 'ISKP.NEQ ';
S1MNEM [XISKP_GEQ] := 'ISKP.GEQ ';
S1MNEM [XISKP_GTR] := 'ISKP.GTR ';
S1MNEM [XISKP_LEQ] := 'ISKP.LEQ ';
S1MNEM [XISKP_LSS] := 'ISKP.LSS ';
S1MNEM [XJMPA] := 'JMPA ';
S1MNEM [XJMPZ_EQL_Q] := 'JMPZ.EQL.Q ';
S1MNEM [XJMPZ_NEQ_Q] := 'JMPZ.NEQ.Q ';
S1MNEM [XJSR] := 'JSR ';
S1MNEM [XMOV_A] := 'MOVADR ';
S1MNEM [XMOV_Q_Q] := 'MOV.Q.Q ';
S1MNEM [XMOV_Q_H] := 'MOV.Q.H ';
S1MNEM [XMOV_H_Q] := 'MOV.H.Q ';
S1MNEM [XMOV_H_H] := 'MOV.H.H ';
S1MNEM [XMOV_Q_S] := 'MOV.Q.S ';
S1MNEM [XMOV_H_S] := 'MOV.H.S ';
S1MNEM [XMOV_S_Q] := 'MOV.S.Q ';
S1MNEM [XMOV_S_H] := 'MOV.S.H ';
S1MNEM [XMOV_S_S] := 'MOV.S.S ';
S1MNEM [XMOV_Q_D] := 'MOV.Q.D ';
S1MNEM [XMOV_H_D] := 'MOV.H.D ';
S1MNEM [XMOV_S_D] := 'MOV.S.D ';
S1MNEM [XMOV_D_Q] := 'MOV.D.Q ';
S1MNEM [XMOV_D_H] := 'MOV.D.H ';
S1MNEM [XMOV_D_S] := 'MOV.D.S ';
S1MNEM [XMOV_D_D] := 'MOV.D.D ';
S1MNEM [XMOVMQ_2] := 'MOVMQ.2 ';
S1MNEM [XMOVMQ_3] := 'MOVMQ.3 ';
S1MNEM [XMOVMQ_4] := 'MOVMQ.4 ';
S1MNEM [XMOVMQ_5] := 'MOVMQ.5 ';
S1MNEM [XMOVMQ_6] := 'MOVMQ.6 ';
S1MNEM [XMOVMQ_7] := 'MOVMQ.7 ';
S1MNEM [XMOVMQ_8] := 'MOVMQ.8 ';
S1MNEM [XMOVMQ_9] := 'MOVMQ.9 ';
S1MNEM [XMOVMQ_10] := 'MOVMQ.10 ';
S1MNEM [XMOVMQ_11] := 'MOVMQ.11 ';
S1MNEM [XMOVMQ_12] := 'MOVMQ.12 ';
S1MNEM [XMOVMQ_13] := 'MOVMQ.13 ';
S1MNEM [XMOVMQ_14] := 'MOVMQ.14 ';
S1MNEM [XMOVMQ_15] := 'MOVMQ.15 ';
S1MNEM [XMOVMQ_16] := 'MOVMQ.16 ';
S1MNEM [XMOVMQ_17] := 'MOVMQ.17 ';
S1MNEM [XMOVMQ_18] := 'MOVMQ.18 ';
S1MNEM [XMOVMQ_19] := 'MOVMQ.19 ';
S1MNEM [XMOVMQ_20] := 'MOVMQ.20 ';
S1MNEM [XMOVMQ_21] := 'MOVMQ.21 ';
S1MNEM [XMOVMQ_22] := 'MOVMQ.22 ';
S1MNEM [XMOVMQ_23] := 'MOVMQ.23 ';
S1MNEM [XMOVMQ_24] := 'MOVMQ.24 ';
S1MNEM [XMOVMQ_25] := 'MOVMQ.25 ';
S1MNEM [XMOVMQ_26] := 'MOVMQ.26 ';
S1MNEM [XMOVMQ_27] := 'MOVMQ.27 ';
S1MNEM [XMOVMQ_28] := 'MOVMQ.28 ';
S1MNEM [XMOVMQ_29] := 'MOVMQ.29 ';
S1MNEM [XMOVMQ_30] := 'MOVMQ.30 ';
S1MNEM [XMOVMQ_31] := 'MOVMQ.31 ';
S1MNEM [XMOVMQ_32] := 'MOVMQ.32 ';
S1MNEM [XMOVMQ_64] := 'MOVMQ.64 ';
S1MNEM [XMOVMQ_128] := 'MOVMQ.128 ';
S1MNEM [XMOVMS_2] := 'MOVMS.2 ';
S1MNEM [XMOVMS_3] := 'MOVMS.3 ';
S1MNEM [XMOVMS_4] := 'MOVMS.4 ';
S1MNEM [XMOVMS_5] := 'MOVMS.5 ';
S1MNEM [XMOVMS_6] := 'MOVMS.6 ';
S1MNEM [XMOVMS_7] := 'MOVMS.7 ';
S1MNEM [XMOVMS_8] := 'MOVMS.8 ';
S1MNEM [XMOVMS_9] := 'MOVMS.9 ';
S1MNEM [XMOVMS_10] := 'MOVMS.10 ';
S1MNEM [XMOVMS_11] := 'MOVMS.11 ';
S1MNEM [XMOVMS_12] := 'MOVMS.12 ';
S1MNEM [XMOVMS_13] := 'MOVMS.13 ';
S1MNEM [XMOVMS_14] := 'MOVMS.14 ';
S1MNEM [XMOVMS_15] := 'MOVMS.15 ';
S1MNEM [XMOVMS_16] := 'MOVMS.16 ';
S1MNEM [XMOVMS_17] := 'MOVMS.17 ';
S1MNEM [XMOVMS_18] := 'MOVMS.18 ';
S1MNEM [XMOVMS_19] := 'MOVMS.19 ';
S1MNEM [XMOVMS_20] := 'MOVMS.20 ';
S1MNEM [XMOVMS_21] := 'MOVMS.21 ';
S1MNEM [XMOVMS_22] := 'MOVMS.22 ';
S1MNEM [XMOVMS_23] := 'MOVMS.23 ';
S1MNEM [XMOVMS_24] := 'MOVMS.24 ';
S1MNEM [XMOVMS_25] := 'MOVMS.25 ';
S1MNEM [XMOVMS_26] := 'MOVMS.26 ';
S1MNEM [XMOVMS_27] := 'MOVMS.27 ';
S1MNEM [XMOVMS_28] := 'MOVMS.28 ';
S1MNEM [XMOVMS_29] := 'MOVMS.29 ';
S1MNEM [XMOVMS_30] := 'MOVMS.30 ';
S1MNEM [XMOVMS_31] := 'MOVMS.31 ';
S1MNEM [XMOVMS_32] := 'MOVMS.32 ';
S1MNEM [XMULT_S] := 'MULT.S ';
S1MNEM [XMULT_D] := 'MULT.D ';
S1MNEM [XDIV_S] := 'DIV.S ';
S1MNEM [XNEG_Q] := 'NEG.Q ';
S1MNEM [XNEG_H] := 'NEG.H ';
S1MNEM [XNEG_S] := 'NEG.S ';
S1MNEM [XNEG_D] := 'NEG.D ';
S1MNEM [XNOP] := 'NOP ';
S1MNEM [XOR_Q] := 'OR.Q ';
S1MNEM [XOR_D] := 'OR.D ';
S1MNEM [XQUO_S] := 'QUO.S ';
S1MNEM [XQUOV_S] := 'QUOV.S ';
S1MNEM [XQUO_D] := 'QUO.D ';
S1MNEM [XQUOV_D] := 'QUOV.D ';
S1MNEM [XREM_S] := 'REM.S ';
S1MNEM [XREMV_S] := 'REMV.S ';
S1MNEM [XREM_D] := 'REM.D ';
S1MNEM [XREMV_D] := 'REMV.D ';
S1MNEM [XRETSR] := 'RETSR ';
S1MNEM [XSHF_LF_D] := 'SHF.LF.D ';
S1MNEM [XSHFV_LF_D] := 'SHFV.LF.D ';
S1MNEM [XSHFA_LF_S] := 'SHFA.LF.S ';
S1MNEM [XSHFAV_LF_S] := 'SHFAV.LF.S ';
S1MNEM [XSKP_EQL_Q] := 'SKP.EQL.Q ';
S1MNEM [XSKP_NEQ_Q] := 'SKP.NEQ.Q ';
S1MNEM [XSKP_GEQ_Q] := 'SKP.GEQ.Q ';
S1MNEM [XSKP_GTR_Q] := 'SKP.GTR.Q ';
S1MNEM [XSKP_LEQ_Q] := 'SKP.LEQ.Q ';
S1MNEM [XSKP_LSS_Q] := 'SKP.LSS.Q ';
S1MNEM [XSKP_EQL_H] := 'SKP.EQL.H ';
S1MNEM [XSKP_NEQ_H] := 'SKP.NEQ.H ';
S1MNEM [XSKP_GEQ_H] := 'SKP.GEQ.H ';
S1MNEM [XSKP_GTR_H] := 'SKP.GTR.H ';
S1MNEM [XSKP_LEQ_H] := 'SKP.LEQ.H ';
S1MNEM [XSKP_LSS_H] := 'SKP.LSS.H ';
S1MNEM [XSKP_EQL_S] := 'SKP.EQL.S ';
S1MNEM [XSKP_NEQ_S] := 'SKP.NEQ.S ';
S1MNEM [XSKP_GEQ_S] := 'SKP.GEQ.S ';
S1MNEM [XSKP_GTR_S] := 'SKP.GTR.S ';
S1MNEM [XSKP_LEQ_S] := 'SKP.LEQ.S ';
S1MNEM [XSKP_LSS_S] := 'SKP.LSS.S ';
S1MNEM [XSKP_EQL_D] := 'SKP.EQL.D ';
S1MNEM [XSKP_NEQ_D] := 'SKP.NEQ.D ';
S1MNEM [XSKP_GEQ_D] := 'SKP.GEQ.D ';
S1MNEM [XSKP_GTR_D] := 'SKP.GTR.D ';
S1MNEM [XSKP_LEQ_D] := 'SKP.LEQ.D ';
S1MNEM [XSKP_LSS_D] := 'SKP.LSS.D ';
S1MNEM [XSKP_NON_Q] := 'SKP.NON.Q ';
S1MNEM [XSKP_NON_H] := 'SKP.NON.H ';
S1MNEM [XSKP_NON_S] := 'SKP.NON.S ';
S1MNEM [XSKP_NON_D] := 'SKP.NON.D ';
S1MNEM [XSKP_ANY_Q] := 'SKP.ANY.Q ';
S1MNEM [XSKP_ANY_H] := 'SKP.ANY.H ';
S1MNEM [XSKP_ANY_S] := 'SKP.ANY.S ';
S1MNEM [XSKP_ANY_D] := 'SKP.ANY.D ';
S1MNEM [XSLR_0] := 'SLR.0 ';
S1MNEM [XSLR_1] := 'SLR.1 ';
S1MNEM [XSLR_2] := 'SLR.2 ';
S1MNEM [XSLR_3] := 'SLR.3 ';
S1MNEM [XSLR_4] := 'SLR.4 ';
S1MNEM [XSLR_5] := 'SLR.5 ';
S1MNEM [XSLR_6] := 'SLR.6 ';
S1MNEM [XSLR_7] := 'SLR.7 ';
S1MNEM [XSLR_8] := 'SLR.8 ';
S1MNEM [XSLR_9] := 'SLR.9 ';
S1MNEM [XSLR_10] := 'SLR.10 ';
S1MNEM [XSLR_11] := 'SLR.11 ';
S1MNEM [XSLR_12] := 'SLR.12 ';
S1MNEM [XSLR_13] := 'SLR.13 ';
S1MNEM [XSLR_14] := 'SLR.14 ';
S1MNEM [XSLR_15] := 'SLR.15 ';
S1MNEM [XSLR_16] := 'SLR.16 ';
S1MNEM [XSLR_17] := 'SLR.17 ';
S1MNEM [XSLR_18] := 'SLR.18 ';
S1MNEM [XSLR_19] := 'SLR.19 ';
S1MNEM [XSLR_20] := 'SLR.20 ';
S1MNEM [XSLR_21] := 'SLR.21 ';
S1MNEM [XSLR_22] := 'SLR.22 ';
S1MNEM [XSLR_23] := 'SLR.23 ';
S1MNEM [XSLR_24] := 'SLR.24 ';
S1MNEM [XSLR_25] := 'SLR.25 ';
S1MNEM [XSLR_26] := 'SLR.26 ';
S1MNEM [XSLR_27] := 'SLR.27 ';
S1MNEM [XSLR_28] := 'SLR.28 ';
S1MNEM [XSLR_29] := 'SLR.29 ';
S1MNEM [XSLR_30] := 'SLR.30 ';
S1MNEM [XSLR_31] := 'SLR.31 ';
S1MNEM [XSLRADR_0] := 'SLRADR.0 ';
S1MNEM [XSLRADR_1] := 'SLRADR.1 ';
S1MNEM [XSLRADR_2] := 'SLRADR.2 ';
S1MNEM [XSLRADR_3] := 'SLRADR.3 ';
S1MNEM [XSLRADR_4] := 'SLRADR.4 ';
S1MNEM [XSLRADR_5] := 'SLRADR.5 ';
S1MNEM [XSLRADR_6] := 'SLRADR.6 ';
S1MNEM [XSLRADR_7] := 'SLRADR.7 ';
S1MNEM [XSLRADR_8] := 'SLRADR.8 ';
S1MNEM [XSLRADR_9] := 'SLRADR.9 ';
S1MNEM [XSLRADR_10] := 'SLRADR.10 ';
S1MNEM [XSLRADR_11] := 'SLRADR.11 ';
S1MNEM [XSLRADR_12] := 'SLRADR.12 ';
S1MNEM [XSLRADR_13] := 'SLRADR.13 ';
S1MNEM [XSLRADR_14] := 'SLRADR.14 ';
S1MNEM [XSLRADR_15] := 'SLRADR.15 ';
S1MNEM [XSLRADR_16] := 'SLRADR.16 ';
S1MNEM [XSLRADR_17] := 'SLRADR.17 ';
S1MNEM [XSLRADR_18] := 'SLRADR.18 ';
S1MNEM [XSLRADR_19] := 'SLRADR.19 ';
S1MNEM [XSLRADR_20] := 'SLRADR.20 ';
S1MNEM [XSLRADR_21] := 'SLRADR.21 ';
S1MNEM [XSLRADR_22] := 'SLRADR.22 ';
S1MNEM [XSLRADR_23] := 'SLRADR.23 ';
S1MNEM [XSLRADR_24] := 'SLRADR.24 ';
S1MNEM [XSLRADR_25] := 'SLRADR.25 ';
S1MNEM [XSLRADR_26] := 'SLRADR.26 ';
S1MNEM [XSLRADR_27] := 'SLRADR.27 ';
S1MNEM [XSLRADR_28] := 'SLRADR.28 ';
S1MNEM [XSLRADR_29] := 'SLRADR.29 ';
S1MNEM [XSLRADR_30] := 'SLRADR.30 ';
S1MNEM [XSLRADR_31] := 'SLRADR.31 ';
S1MNEM [XSUB_S] := 'SUB.S ';
S1MNEM [XSUBV_S] := 'SUBV.S ';
S1MNEM [XSUB_D] := 'SUB.D ';
S1MNEM [XSUBV_D] := 'SUBV.D ';
S1MNEM [XTRANS_Q_Q] := 'TRANS.Q.Q ';
S1MNEM [XTRANS_Q_H] := 'TRANS.Q.H ';
S1MNEM [XTRANS_H_Q] := 'TRANS.H.Q ';
S1MNEM [XTRANS_H_H] := 'TRANS.H.H ';
S1MNEM [XTRANS_Q_S] := 'TRANS.Q.S ';
S1MNEM [XTRANS_H_S] := 'TRANS.H.S ';
S1MNEM [XTRANS_S_Q] := 'TRANS.S.Q ';
S1MNEM [XTRANS_S_H] := 'TRANS.S.H ';
S1MNEM [XTRANS_S_S] := 'TRANS.S.S ';
S1MNEM [XTRANS_Q_D] := 'TRANS.Q.D ';
S1MNEM [XTRANS_H_D] := 'TRANS.H.D ';
S1MNEM [XTRANS_S_D] := 'TRANS.S.D ';
S1MNEM [XTRANS_D_Q] := 'TRANS.D.Q ';
S1MNEM [XTRANS_D_H] := 'TRANS.D.H ';
S1MNEM [XTRANS_D_S] := 'TRANS.D.S ';
S1MNEM [XTRANS_D_D] := 'TRANS.D.D ';
S1MNEM [XXOR_Q] := 'XOR.Q ';
(* END S1MNEM MARKER FOR OPS.PAS *)
end (*INIT4*);
(** INITIALIZE_CLASS: INIT5 **)
(**)
procedure INIT5;
begin
(* HARDOPCODEs for FAKEOPs should start at 4095 and work down. PBK*)
HARDOPCODE [XILLEGAL ] := 4095; (*PBK*)
HARDOPCODE [XPLOC ] := 4094; (*PBK*)
HARDOPCODE [XS1LOC ] := 4093; (*PBK*)
HARDOPCODE [XFREEREG ] := 4092; (*PBK*)
(* GENERATED SOPA OPCODES USING OPS.IN OF 13DEC78 2219 JBR *)
HARDOPCODE [XABS_Q ] := 1487;
HARDOPCODE [XABS_H ] := 1488;
HARDOPCODE [XABS_S ] := 1489;
HARDOPCODE [XABS_D ] := 1490;
HARDOPCODE [XADD_S ] := 12;
HARDOPCODE [XADD_D ] := 16;
HARDOPCODE [XADJSP_UP ] := 1830;
HARDOPCODE [XADJSP_DN ] := 1831;
HARDOPCODE [XALLOC_1 ] := 1666;
HARDOPCODE [XAND_Q ] := 736;
HARDOPCODE [XAND_D ] := 748;
HARDOPCODE [XAND_TC_D ] := 764;
HARDOPCODE [XAND_CT_D ] := 780;
HARDOPCODE [XBLCMP_EQL_Q ] := 1866;
HARDOPCODE [XBLCMP_NEQ_Q ] := 1878;
HARDOPCODE [XBLCMP_GEQ_Q ] := 1870;
HARDOPCODE [XBLCMP_GTR_Q ] := 1862;
HARDOPCODE [XBLCMP_LEQ_Q ] := 1882;
HARDOPCODE [XBLCMP_LSS_Q ] := 1874;
HARDOPCODE [XBLKMOV ] := 1886;
HARDOPCODE [XBTRP_B_Q ] := 1645;
HARDOPCODE [XBTRP_B_H ] := 1646;
HARDOPCODE [XBTRP_B_S ] := 1647;
HARDOPCODE [XBTRP_B_D ] := 1648;
HARDOPCODE [XBTRP_M1_Q ] := 1653;
HARDOPCODE [XBTRP_M1_H ] := 1654;
HARDOPCODE [XBTRP_M1_S ] := 1655;
HARDOPCODE [XBTRP_M1_D ] := 1656;
HARDOPCODE [XBTRP_0_Q ] := 1657;
HARDOPCODE [XBTRP_0_H ] := 1658;
HARDOPCODE [XBTRP_0_S ] := 1659;
HARDOPCODE [XBTRP_0_D ] := 1660;
HARDOPCODE [XBTRP_1_Q ] := 1661;
HARDOPCODE [XBTRP_1_H ] := 1662;
HARDOPCODE [XBTRP_1_S ] := 1663;
HARDOPCODE [XBTRP_1_D ] := 1664;
HARDOPCODE [XDEC_S ] := 1384;
HARDOPCODE [XDJMPA ] := 1348;
HARDOPCODE [XDSKP_EQL ] := 2800;
HARDOPCODE [XDSKP_NEQ ] := 2848;
HARDOPCODE [XDSKP_GEQ ] := 2816;
HARDOPCODE [XDSKP_GTR ] := 2784;
HARDOPCODE [XDSKP_LEQ ] := 2864;
HARDOPCODE [XDSKP_LSS ] := 2832;
HARDOPCODE [XFX_DM_S_S ] := 1433;
HARDOPCODE [XFX_DM_S_D ] := 1434;
HARDOPCODE [XFX_FL_S_S ] := 1409;
HARDOPCODE [XFLOAT_S_Q ] := 1466;
HARDOPCODE [XFLOAT_S_H ] := 1467;
HARDOPCODE [XFLOAT_S_S ] := 1468;
HARDOPCODE [XFLOAT_S_D ] := 1469;
HARDOPCODE [XFADD_S ] := 412;
HARDOPCODE [XFADD_D ] := 416;
HARDOPCODE [XFSUB_S ] := 424;
HARDOPCODE [XFSUBV_S ] := 436;
HARDOPCODE [XFSUB_D ] := 428;
HARDOPCODE [XFSUBV_D ] := 440;
HARDOPCODE [XFMULT_S ] := 448;
HARDOPCODE [XFMULT_D ] := 452;
HARDOPCODE [XFDIV_S ] := 468;
HARDOPCODE [XFDIVV_S ] := 480;
HARDOPCODE [XFDIV_D ] := 472;
HARDOPCODE [XFDIVV_D ] := 484;
HARDOPCODE [XFTRANS_S_D ] := 1479;
HARDOPCODE [XFTRANS_D_S ] := 1481;
HARDOPCODE [XHALT ] := 1376;
HARDOPCODE [XIJMPA ] := 1322;
HARDOPCODE [XINC_S ] := 1380;
HARDOPCODE [XISKP_EQL ] := 2704;
HARDOPCODE [XISKP_NEQ ] := 2752;
HARDOPCODE [XISKP_GEQ ] := 2720;
HARDOPCODE [XISKP_GTR ] := 2688;
HARDOPCODE [XISKP_LEQ ] := 2768;
HARDOPCODE [XISKP_LSS ] := 2736;
HARDOPCODE [XJMPA ] := 1296;
HARDOPCODE [XJMPZ_EQL_Q ] := 1256;
HARDOPCODE [XJMPZ_NEQ_Q ] := 1280;
HARDOPCODE [XJSR ] := 1350;
HARDOPCODE [XMOV_A ] := 1639;
HARDOPCODE [XMOV_Q_Q ] := 1491;
HARDOPCODE [XMOV_Q_H ] := 1492;
HARDOPCODE [XMOV_H_Q ] := 1495;
HARDOPCODE [XMOV_H_H ] := 1496;
HARDOPCODE [XMOV_Q_S ] := 1493;
HARDOPCODE [XMOV_H_S ] := 1497;
HARDOPCODE [XMOV_S_Q ] := 1499;
HARDOPCODE [XMOV_S_H ] := 1500;
HARDOPCODE [XMOV_S_S ] := 1501;
HARDOPCODE [XMOV_Q_D ] := 1494;
HARDOPCODE [XMOV_H_D ] := 1498;
HARDOPCODE [XMOV_S_D ] := 1502;
HARDOPCODE [XMOV_D_Q ] := 1503;
HARDOPCODE [XMOV_D_H ] := 1504;
HARDOPCODE [XMOV_D_S ] := 1505;
HARDOPCODE [XMOV_D_D ] := 1506;
HARDOPCODE [XMOVMQ_2 ] := 1507;
HARDOPCODE [XMOVMQ_3 ] := 1508;
HARDOPCODE [XMOVMQ_4 ] := 1509;
HARDOPCODE [XMOVMQ_5 ] := 1510;
HARDOPCODE [XMOVMQ_6 ] := 1511;
HARDOPCODE [XMOVMQ_7 ] := 1512;
HARDOPCODE [XMOVMQ_8 ] := 1513;
HARDOPCODE [XMOVMQ_9 ] := 1514;
HARDOPCODE [XMOVMQ_10 ] := 1515;
HARDOPCODE [XMOVMQ_11 ] := 1516;
HARDOPCODE [XMOVMQ_12 ] := 1517;
HARDOPCODE [XMOVMQ_13 ] := 1518;
HARDOPCODE [XMOVMQ_14 ] := 1519;
HARDOPCODE [XMOVMQ_15 ] := 1520;
HARDOPCODE [XMOVMQ_16 ] := 1521;
HARDOPCODE [XMOVMQ_17 ] := 1522;
HARDOPCODE [XMOVMQ_18 ] := 1523;
HARDOPCODE [XMOVMQ_19 ] := 1524;
HARDOPCODE [XMOVMQ_20 ] := 1525;
HARDOPCODE [XMOVMQ_21 ] := 1526;
HARDOPCODE [XMOVMQ_22 ] := 1527;
HARDOPCODE [XMOVMQ_23 ] := 1528;
HARDOPCODE [XMOVMQ_24 ] := 1529;
HARDOPCODE [XMOVMQ_25 ] := 1530;
HARDOPCODE [XMOVMQ_26 ] := 1531;
HARDOPCODE [XMOVMQ_27 ] := 1532;
HARDOPCODE [XMOVMQ_28 ] := 1533;
HARDOPCODE [XMOVMQ_29 ] := 1534;
HARDOPCODE [XMOVMQ_30 ] := 1535;
HARDOPCODE [XMOVMQ_31 ] := 1536;
HARDOPCODE [XMOVMQ_32 ] := 1537;
HARDOPCODE [XMOVMQ_64 ] := 1538;
HARDOPCODE [XMOVMQ_128 ] := 1539;
HARDOPCODE [XMOVMS_2 ] := 1540;
HARDOPCODE [XMOVMS_3 ] := 1541;
HARDOPCODE [XMOVMS_4 ] := 1542;
HARDOPCODE [XMOVMS_5 ] := 1543;
HARDOPCODE [XMOVMS_6 ] := 1544;
HARDOPCODE [XMOVMS_7 ] := 1545;
HARDOPCODE [XMOVMS_8 ] := 1546;
HARDOPCODE [XMOVMS_9 ] := 1547;
HARDOPCODE [XMOVMS_10 ] := 1548;
HARDOPCODE [XMOVMS_11 ] := 1549;
HARDOPCODE [XMOVMS_12 ] := 1550;
HARDOPCODE [XMOVMS_13 ] := 1551;
HARDOPCODE [XMOVMS_14 ] := 1552;
HARDOPCODE [XMOVMS_15 ] := 1553;
HARDOPCODE [XMOVMS_16 ] := 1554;
HARDOPCODE [XMOVMS_17 ] := 1555;
HARDOPCODE [XMOVMS_18 ] := 1556;
HARDOPCODE [XMOVMS_19 ] := 1557;
HARDOPCODE [XMOVMS_20 ] := 1558;
HARDOPCODE [XMOVMS_21 ] := 1559;
HARDOPCODE [XMOVMS_22 ] := 1560;
HARDOPCODE [XMOVMS_23 ] := 1561;
HARDOPCODE [XMOVMS_24 ] := 1562;
HARDOPCODE [XMOVMS_25 ] := 1563;
HARDOPCODE [XMOVMS_26 ] := 1564;
HARDOPCODE [XMOVMS_27 ] := 1565;
HARDOPCODE [XMOVMS_28 ] := 1566;
HARDOPCODE [XMOVMS_29 ] := 1567;
HARDOPCODE [XMOVMS_30 ] := 1568;
HARDOPCODE [XMOVMS_31 ] := 1569;
HARDOPCODE [XMOVMS_32 ] := 1570;
HARDOPCODE [XMULT_S ] := 108;
HARDOPCODE [XMULT_D ] := 112;
HARDOPCODE [XDIV_S ] := 360;
HARDOPCODE [XNEG_Q ] := 1483;
HARDOPCODE [XNEG_H ] := 1484;
HARDOPCODE [XNEG_S ] := 1485;
HARDOPCODE [XNEG_D ] := 1486;
HARDOPCODE [XNOP ] := 1939;
HARDOPCODE [XOR_Q ] := 784;
HARDOPCODE [XOR_D ] := 796;
HARDOPCODE [XQUO_S ] := 136;
HARDOPCODE [XQUOV_S ] := 152;
HARDOPCODE [XQUO_D ] := 140;
HARDOPCODE [XQUOV_D ] := 156;
HARDOPCODE [XREM_S ] := 248;
HARDOPCODE [XREMV_S ] := 264;
HARDOPCODE [XREM_D ] := 252;
HARDOPCODE [XREMV_D ] := 268;
HARDOPCODE [XRETSR ] := 1698;
HARDOPCODE [XSHF_LF_D ] := 908;
HARDOPCODE [XSHFV_LF_D ] := 940;
HARDOPCODE [XSHFA_LF_S ] := 1016;
HARDOPCODE [XSHFAV_LF_S ] := 1048;
HARDOPCODE [XSKP_EQL_Q ] := 2112;
HARDOPCODE [XSKP_NEQ_Q ] := 2304;
HARDOPCODE [XSKP_GEQ_Q ] := 2176;
HARDOPCODE [XSKP_GTR_Q ] := 2048;
HARDOPCODE [XSKP_LEQ_Q ] := 2368;
HARDOPCODE [XSKP_LSS_Q ] := 2240;
HARDOPCODE [XSKP_EQL_H ] := 2128;
HARDOPCODE [XSKP_NEQ_H ] := 2320;
HARDOPCODE [XSKP_GEQ_H ] := 2192;
HARDOPCODE [XSKP_GTR_H ] := 2064;
HARDOPCODE [XSKP_LEQ_H ] := 2384;
HARDOPCODE [XSKP_LSS_H ] := 2256;
HARDOPCODE [XSKP_EQL_S ] := 2144;
HARDOPCODE [XSKP_NEQ_S ] := 2336;
HARDOPCODE [XSKP_GEQ_S ] := 2208;
HARDOPCODE [XSKP_GTR_S ] := 2080;
HARDOPCODE [XSKP_LEQ_S ] := 2400;
HARDOPCODE [XSKP_LSS_S ] := 2272;
HARDOPCODE [XSKP_EQL_D ] := 2160;
HARDOPCODE [XSKP_NEQ_D ] := 2352;
HARDOPCODE [XSKP_GEQ_D ] := 2224;
HARDOPCODE [XSKP_GTR_D ] := 2096;
HARDOPCODE [XSKP_LEQ_D ] := 2416;
HARDOPCODE [XSKP_LSS_D ] := 2288;
HARDOPCODE [XSKP_NON_Q ] := 2432;
HARDOPCODE [XSKP_NON_H ] := 2448;
HARDOPCODE [XSKP_NON_S ] := 2464;
HARDOPCODE [XSKP_NON_D ] := 2480;
HARDOPCODE [XSKP_ANY_Q ] := 2624;
HARDOPCODE [XSKP_ANY_H ] := 2640;
HARDOPCODE [XSKP_ANY_S ] := 2656;
HARDOPCODE [XSKP_ANY_D ] := 2672;
HARDOPCODE [XSLR_0 ] := 1575;
HARDOPCODE [XSLR_1 ] := 1576;
HARDOPCODE [XSLR_2 ] := 1577;
HARDOPCODE [XSLR_3 ] := 1578;
HARDOPCODE [XSLR_4 ] := 1579;
HARDOPCODE [XSLR_5 ] := 1580;
HARDOPCODE [XSLR_6 ] := 1581;
HARDOPCODE [XSLR_7 ] := 1582;
HARDOPCODE [XSLR_8 ] := 1583;
HARDOPCODE [XSLR_9 ] := 1584;
HARDOPCODE [XSLR_10 ] := 1585;
HARDOPCODE [XSLR_11 ] := 1586;
HARDOPCODE [XSLR_12 ] := 1587;
HARDOPCODE [XSLR_13 ] := 1588;
HARDOPCODE [XSLR_14 ] := 1589;
HARDOPCODE [XSLR_15 ] := 1590;
HARDOPCODE [XSLR_16 ] := 1591;
HARDOPCODE [XSLR_17 ] := 1592;
HARDOPCODE [XSLR_18 ] := 1593;
HARDOPCODE [XSLR_19 ] := 1594;
HARDOPCODE [XSLR_20 ] := 1595;
HARDOPCODE [XSLR_21 ] := 1596;
HARDOPCODE [XSLR_22 ] := 1597;
HARDOPCODE [XSLR_23 ] := 1598;
HARDOPCODE [XSLR_24 ] := 1599;
HARDOPCODE [XSLR_25 ] := 1600;
HARDOPCODE [XSLR_26 ] := 1601;
HARDOPCODE [XSLR_27 ] := 1602;
HARDOPCODE [XSLR_28 ] := 1603;
HARDOPCODE [XSLR_29 ] := 1604;
HARDOPCODE [XSLR_30 ] := 1605;
HARDOPCODE [XSLR_31 ] := 1606;
HARDOPCODE [XSLRADR_0 ] := 1607;
HARDOPCODE [XSLRADR_1 ] := 1608;
HARDOPCODE [XSLRADR_2 ] := 1609;
HARDOPCODE [XSLRADR_3 ] := 1610;
HARDOPCODE [XSLRADR_4 ] := 1611;
HARDOPCODE [XSLRADR_5 ] := 1612;
HARDOPCODE [XSLRADR_6 ] := 1613;
HARDOPCODE [XSLRADR_7 ] := 1614;
HARDOPCODE [XSLRADR_8 ] := 1615;
HARDOPCODE [XSLRADR_9 ] := 1616;
HARDOPCODE [XSLRADR_10 ] := 1617;
HARDOPCODE [XSLRADR_11 ] := 1618;
HARDOPCODE [XSLRADR_12 ] := 1619;
HARDOPCODE [XSLRADR_13 ] := 1620;
HARDOPCODE [XSLRADR_14 ] := 1621;
HARDOPCODE [XSLRADR_15 ] := 1622;
HARDOPCODE [XSLRADR_16 ] := 1623;
HARDOPCODE [XSLRADR_17 ] := 1624;
HARDOPCODE [XSLRADR_18 ] := 1625;
HARDOPCODE [XSLRADR_19 ] := 1626;
HARDOPCODE [XSLRADR_20 ] := 1627;
HARDOPCODE [XSLRADR_21 ] := 1628;
HARDOPCODE [XSLRADR_22 ] := 1629;
HARDOPCODE [XSLRADR_23 ] := 1630;
HARDOPCODE [XSLRADR_24 ] := 1631;
HARDOPCODE [XSLRADR_25 ] := 1632;
HARDOPCODE [XSLRADR_26 ] := 1633;
HARDOPCODE [XSLRADR_27 ] := 1634;
HARDOPCODE [XSLRADR_28 ] := 1635;
HARDOPCODE [XSLRADR_29 ] := 1636;
HARDOPCODE [XSLRADR_30 ] := 1637;
HARDOPCODE [XSLRADR_31 ] := 1638;
HARDOPCODE [XSUB_S ] := 44;
HARDOPCODE [XSUBV_S ] := 60;
HARDOPCODE [XSUB_D ] := 48;
HARDOPCODE [XSUBV_D ] := 64;
HARDOPCODE [XTRANS_Q_Q ] := 1386;
HARDOPCODE [XTRANS_Q_H ] := 1387;
HARDOPCODE [XTRANS_H_Q ] := 1390;
HARDOPCODE [XTRANS_H_H ] := 1391;
HARDOPCODE [XTRANS_Q_S ] := 1388;
HARDOPCODE [XTRANS_H_S ] := 1392;
HARDOPCODE [XTRANS_S_Q ] := 1394;
HARDOPCODE [XTRANS_S_H ] := 1395;
HARDOPCODE [XTRANS_S_S ] := 1396;
HARDOPCODE [XTRANS_Q_D ] := 1389;
HARDOPCODE [XTRANS_H_D ] := 1393;
HARDOPCODE [XTRANS_S_D ] := 1397;
HARDOPCODE [XTRANS_D_Q ] := 1398;
HARDOPCODE [XTRANS_D_H ] := 1399;
HARDOPCODE [XTRANS_D_S ] := 1400;
HARDOPCODE [XTRANS_D_D ] := 1401;
HARDOPCODE [XXOR_Q ] := 864;
end (*INIT5*);
(** INITIALIZE_CLASS: INIT6 **)
(**)
procedure INIT6;
begin
for S1OP := FIRSTSKIP to LASTSKIP do
INVERSE_SKIP[S1OP] := XILLEGAL;
INVERSE_SKIP [XDSKP_EQL] := XDSKP_NEQ; (*25JUN79 PTZ...*)
INVERSE_SKIP [XDSKP_NEQ] := XDSKP_EQL;
INVERSE_SKIP [XDSKP_GEQ] := XDSKP_LSS;
INVERSE_SKIP [XDSKP_LSS] := XDSKP_GEQ;
INVERSE_SKIP [XDSKP_GTR] := XDSKP_LEQ;
INVERSE_SKIP [XDSKP_LEQ] := XDSKP_GTR;
INVERSE_SKIP [XISKP_EQL] := XISKP_NEQ;
INVERSE_SKIP [XISKP_NEQ] := XISKP_EQL;
INVERSE_SKIP [XISKP_GEQ] := XISKP_LSS;
INVERSE_SKIP [XISKP_LSS] := XISKP_GEQ;
INVERSE_SKIP [XISKP_GTR] := XISKP_LEQ;
INVERSE_SKIP [XISKP_LEQ] := XISKP_GTR; (*...25JUN79 PTZ*)
INVERSE_SKIP [XSKP_EQL_Q] := XSKP_NEQ_Q;
INVERSE_SKIP [XSKP_NEQ_Q] := XSKP_EQL_Q;
INVERSE_SKIP [XSKP_GEQ_Q] := XSKP_LSS_Q;
INVERSE_SKIP [XSKP_LSS_Q] := XSKP_GEQ_Q;
INVERSE_SKIP [XSKP_GTR_Q] := XSKP_LEQ_Q;
INVERSE_SKIP [XSKP_LEQ_Q] := XSKP_GTR_Q;
INVERSE_SKIP [XSKP_EQL_H] := XSKP_NEQ_H;
INVERSE_SKIP [XSKP_NEQ_H] := XSKP_EQL_H;
INVERSE_SKIP [XSKP_GEQ_H] := XSKP_LSS_H;
INVERSE_SKIP [XSKP_LSS_H] := XSKP_GEQ_H;
INVERSE_SKIP [XSKP_GTR_H] := XSKP_LEQ_H;
INVERSE_SKIP [XSKP_LEQ_H] := XSKP_GTR_H;
INVERSE_SKIP [XSKP_EQL_S] := XSKP_NEQ_S;
INVERSE_SKIP [XSKP_NEQ_S] := XSKP_EQL_S;
INVERSE_SKIP [XSKP_GEQ_S] := XSKP_LSS_S;
INVERSE_SKIP [XSKP_LSS_S] := XSKP_GEQ_S;
INVERSE_SKIP [XSKP_GTR_S] := XSKP_LEQ_S;
INVERSE_SKIP [XSKP_LEQ_S] := XSKP_GTR_S;
INVERSE_SKIP [XSKP_EQL_D] := XSKP_NEQ_D;
INVERSE_SKIP [XSKP_NEQ_D] := XSKP_EQL_D;
INVERSE_SKIP [XSKP_GEQ_D] := XSKP_LSS_D;
INVERSE_SKIP [XSKP_LSS_D] := XSKP_GEQ_D;
INVERSE_SKIP [XSKP_GTR_D] := XSKP_LEQ_D;
INVERSE_SKIP [XSKP_LEQ_D] := XSKP_GTR_D;
INVERSE_SKIP [XSKP_NON_Q] := XSKP_ANY_Q;
INVERSE_SKIP [XSKP_NON_H] := XSKP_ANY_H;
INVERSE_SKIP [XSKP_NON_S] := XSKP_ANY_S;
INVERSE_SKIP [XSKP_NON_D] := XSKP_ANY_D;
INVERSE_SKIP [XSKP_ANY_Q] := XSKP_NON_Q;
INVERSE_SKIP [XSKP_ANY_H] := XSKP_NON_H;
INVERSE_SKIP [XSKP_ANY_S] := XSKP_NON_S;
INVERSE_SKIP [XSKP_ANY_D] := XSKP_NON_D;
for S1OP := FIRSTS1OP to LASTS1OP do (*28JUN79 PTZ...*)
begin
ISKPJMPA_OPCODE[S1OP] := XILLEGAL;
DSKPJMPA_OPCODE[S1OP] := XILLEGAL
end;
ISKPJMPA_OPCODE [XJMPA] := XIJMPA;
ISKPJMPA_OPCODE [XSKP_EQL_S] := XISKP_EQL;
ISKPJMPA_OPCODE [XSKP_NEQ_S] := XISKP_NEQ;
ISKPJMPA_OPCODE [XSKP_GEQ_S] := XISKP_GEQ;
ISKPJMPA_OPCODE [XSKP_LSS_S] := XISKP_LSS;
ISKPJMPA_OPCODE [XSKP_GTR_S] := XISKP_GTR;
ISKPJMPA_OPCODE [XSKP_LEQ_S] := XISKP_LEQ;
DSKPJMPA_OPCODE [XJMPA] := XDJMPA;
DSKPJMPA_OPCODE [XSKP_EQL_S] := XDSKP_EQL;
DSKPJMPA_OPCODE [XSKP_NEQ_S] := XDSKP_NEQ;
DSKPJMPA_OPCODE [XSKP_GEQ_S] := XDSKP_GEQ;
DSKPJMPA_OPCODE [XSKP_LSS_S] := XDSKP_LSS;
DSKPJMPA_OPCODE [XSKP_GTR_S] := XDSKP_GTR;
DSKPJMPA_OPCODE [XSKP_LEQ_S] := XDSKP_LEQ; (*...28JUN79 PTZ*)
for S1OP := FIRSTS1OP to LASTS1OP do
begin
case OPFORMAT[S1OP] of
VFAKEOP, VXOP : N := 1;
VTOP : N := TWOEXP[T_LEN];
VJOP : N := TWOEXP[PR_LEN];
VSOP : N := TWOEXP[SKP_LEN];
end (*case*);
if not ( HARDOPCODE[S1OP] mod N = 0) then ASSERTFAIL('INITIALIZ001');
for I := HARDOPCODE[S1OP] to (HARDOPCODE[S1OP]+N-1) do
SOFTOPCODE[I] := S1OP;
end (*for S1OP := *);
for S1OP := FIRSTS1OP to LASTS1OP do S1OP_CNT[S1OP] := 0; (*LCW*)
WORD_CNT := 0; (*LCW*)
INSTR_WDS_REMOVED := 0; (*PTZ*)
J_TO_J_CNT := 0; (*PBK*)
JMPAS_REMOVED_FROM_SKIPS := 0; (*PTZ*)
for ICNT := 1 to 14 do MOV_COLLAPSE[ICNT] := 0; (*21JUN79 PTZ*)
MOVS_COLLAPSED := 0; (*PTZ*)
for ICNT := 1 to 3 do INC_SKP_COLLAPSE[ICNT] := 0; (*29JUN79 PTZ*)
TR_PEEPHOLE := false; (*15JAN79 PTZ*)
TR_UCODE := false;
TR_S1CODE := false;
TR_STACK := false;
TR_MST := false;
% TR_NEST := false; \(* peg 18jul79*)
TR_SIMP := false;
MAINCODE := EMPTYINSTLIST; (*DATASTRCH*)
NEWINSTREC := nil;
BOT := 1; (*STKINX of the first datum on STK*)(* peg 09jul79 *)
TOP := BOT-1;
CURFRAME := MINFRAME; (* peg 09jul79 *)
STKFRAME[CURFRAME] := BOT; (* peg 09jul79 *)
PREGS_ARCHIVED := false; (* als/peg 18jul79 *)
MSTTOP := 0;
with MSTSTK[MSTTOP] do
begin
DESTLEV := 1;
MSTCODESTART := nil;
CURPARMREGS := 0;
EVALSAVESTART := 0;
end (*with MSTSTK[TOP] do*);
DEBUG := false;
ASM := false;
ERRORCNT := 0;
MAXLVLUSED := 0;
TOTAL_STORAGE := 0; (*31AUG79 PTZ...*)
NUM_PROCS_COMPILED := 0;
MAX_STORAGE := 0; (*...31AUG79 PTZ*)
ICUPSEEN := false;
PSWITCHNAME := '$PSWITCH ';
end (*INIT6*);
(** INITIALIZE_CLASS: INIT7 **)
(**)
procedure INIT7; (*PBK*)
var S1OP : S1OPCODE;
begin
(*Right now COLLAPSIBLE_OP[S1OP] = false iff DEST_PRECISION[S1OP]
= S1ILLEGAL. Someone ought to monitor this & remove COLLAPSIBLE_OP
if the situation persists for a long time. 9/24/78 PTZ*)
(**** What the heck is this array for?? There are some 'new' opcodes
-- should they be in this list?? -- als/peg 18jul79*)
for S1OP := FIRSTS1OP to LASTS1OP do
COLLAPSIBLE_OP [S1OP] := false;
COLLAPSIBLE_OP [XABS_Q] := true;
COLLAPSIBLE_OP [XABS_H] := true;
COLLAPSIBLE_OP [XABS_S] := true;
COLLAPSIBLE_OP [XABS_D] := true;
COLLAPSIBLE_OP [XADD_S] := true;
COLLAPSIBLE_OP [XADD_D] := true;
COLLAPSIBLE_OP [XAND_Q] := true;
COLLAPSIBLE_OP [XAND_D] := true;
COLLAPSIBLE_OP [XAND_TC_D] := true;
COLLAPSIBLE_OP [XAND_CT_D] := true;
COLLAPSIBLE_OP [XDEC_S] := true;
COLLAPSIBLE_OP [XFX_DM_S_S] := true;
COLLAPSIBLE_OP [XFX_DM_S_D] := true;
COLLAPSIBLE_OP [XFLOAT_S_Q] := true;
COLLAPSIBLE_OP [XFLOAT_S_H] := true;
COLLAPSIBLE_OP [XFLOAT_S_S] := true;
COLLAPSIBLE_OP [XFLOAT_S_D] := true;
COLLAPSIBLE_OP [XFADD_S] := true;
COLLAPSIBLE_OP [XFADD_D] := true;
COLLAPSIBLE_OP [XFSUB_S] := true;
COLLAPSIBLE_OP [XFSUBV_S] := true;
COLLAPSIBLE_OP [XFSUB_D] := true;
COLLAPSIBLE_OP [XFSUBV_D] := true;
COLLAPSIBLE_OP [XFMULT_S] := true;
COLLAPSIBLE_OP [XFMULT_D] := true;
COLLAPSIBLE_OP [XFDIV_S] := true;
COLLAPSIBLE_OP [XFDIVV_S] := true;
COLLAPSIBLE_OP [XFDIV_D] := true;
COLLAPSIBLE_OP [XFDIVV_D] := true;
COLLAPSIBLE_OP [XFTRANS_S_D] := true;
COLLAPSIBLE_OP [XFTRANS_D_S] := true;
COLLAPSIBLE_OP [XINC_S] := true;
COLLAPSIBLE_OP [XMOV_A] := true;
COLLAPSIBLE_OP [XMOV_Q_Q] := true;
COLLAPSIBLE_OP [XMOV_Q_H] := true;
COLLAPSIBLE_OP [XMOV_H_Q] := true;
COLLAPSIBLE_OP [XMOV_H_H] := true;
COLLAPSIBLE_OP [XMOV_Q_S] := true;
COLLAPSIBLE_OP [XMOV_H_S] := true;
COLLAPSIBLE_OP [XMOV_S_Q] := true;
COLLAPSIBLE_OP [XMOV_S_H] := true;
COLLAPSIBLE_OP [XMOV_S_S] := true;
COLLAPSIBLE_OP [XMOV_Q_D] := true;
COLLAPSIBLE_OP [XMOV_H_D] := true;
COLLAPSIBLE_OP [XMOV_S_D] := true;
COLLAPSIBLE_OP [XMOV_D_Q] := true;
COLLAPSIBLE_OP [XMOV_D_H] := true;
COLLAPSIBLE_OP [XMOV_D_S] := true;
COLLAPSIBLE_OP [XMOV_D_D] := true;
COLLAPSIBLE_OP [XMULT_S] := true;
COLLAPSIBLE_OP [XMULT_D] := true;
COLLAPSIBLE_OP [XNEG_Q] := true;
COLLAPSIBLE_OP [XNEG_H] := true;
COLLAPSIBLE_OP [XNEG_S] := true;
COLLAPSIBLE_OP [XNEG_D] := true;
COLLAPSIBLE_OP [XOR_Q] := true;
COLLAPSIBLE_OP [XOR_D] := true;
COLLAPSIBLE_OP [XQUO_S] := true;
COLLAPSIBLE_OP [XQUOV_S] := true;
COLLAPSIBLE_OP [XQUO_D] := true;
COLLAPSIBLE_OP [XQUOV_D] := true;
COLLAPSIBLE_OP [XREM_S] := true;
COLLAPSIBLE_OP [XREMV_S] := true;
COLLAPSIBLE_OP [XREM_D] := true;
COLLAPSIBLE_OP [XREMV_D] := true;
COLLAPSIBLE_OP [XSHF_LF_D] := true;
COLLAPSIBLE_OP [XSHFV_LF_D] := true;
COLLAPSIBLE_OP [XSHFA_LF_S] := true;
COLLAPSIBLE_OP [XSHFAV_LF_S] := true;
COLLAPSIBLE_OP [XSUB_S] := true;
COLLAPSIBLE_OP [XSUBV_S] := true;
COLLAPSIBLE_OP [XSUB_D] := true;
COLLAPSIBLE_OP [XSUBV_D] := true;
COLLAPSIBLE_OP [XTRANS_Q_Q] := true;
COLLAPSIBLE_OP [XTRANS_Q_H] := true;
COLLAPSIBLE_OP [XTRANS_H_Q] := true;
COLLAPSIBLE_OP [XTRANS_H_H] := true;
COLLAPSIBLE_OP [XTRANS_Q_S] := true;
COLLAPSIBLE_OP [XTRANS_H_S] := true;
COLLAPSIBLE_OP [XTRANS_S_Q] := true;
COLLAPSIBLE_OP [XTRANS_S_H] := true;
COLLAPSIBLE_OP [XTRANS_S_S] := true;
COLLAPSIBLE_OP [XTRANS_Q_D] := true;
COLLAPSIBLE_OP [XTRANS_H_D] := true;
COLLAPSIBLE_OP [XTRANS_S_D] := true;
COLLAPSIBLE_OP [XTRANS_D_Q] := true;
COLLAPSIBLE_OP [XTRANS_D_H] := true;
COLLAPSIBLE_OP [XTRANS_D_S] := true;
COLLAPSIBLE_OP [XTRANS_D_D] := true;
COLLAPSIBLE_OP [XXOR_Q] := true;
for S1OP := FIRSTS1OP to LASTS1OP do
DEST_PRECISION [S1OP] := S1ILLEGAL;
DEST_PRECISION [XABS_Q] := S1Q;
DEST_PRECISION [XABS_H] := S1H;
DEST_PRECISION [XABS_S] := S1S;
DEST_PRECISION [XABS_D] := S1D;
DEST_PRECISION [XADD_S] := S1S;
DEST_PRECISION [XADD_D] := S1D;
DEST_PRECISION [XAND_Q] := S1Q;
DEST_PRECISION [XAND_D] := S1D;
DEST_PRECISION [XAND_TC_D] := S1D;
DEST_PRECISION [XAND_CT_D] := S1D;
DEST_PRECISION [XDEC_S] := S1S;
DEST_PRECISION [XFX_DM_S_S] := S1S;
DEST_PRECISION [XFX_DM_S_D] := S1S;
DEST_PRECISION [XFLOAT_S_Q] := S1S;
DEST_PRECISION [XFLOAT_S_H] := S1S;
DEST_PRECISION [XFLOAT_S_S] := S1S;
DEST_PRECISION [XFLOAT_S_D] := S1S;
DEST_PRECISION [XFADD_S] := S1S;
DEST_PRECISION [XFADD_D] := S1D;
DEST_PRECISION [XFSUB_S] := S1S;
DEST_PRECISION [XFSUBV_S] := S1S;
DEST_PRECISION [XFSUB_D] := S1D;
DEST_PRECISION [XFSUBV_D] := S1D;
DEST_PRECISION [XFMULT_S] := S1S;
DEST_PRECISION [XFMULT_D] := S1D;
DEST_PRECISION [XFDIV_S] := S1S;
DEST_PRECISION [XFDIVV_S] := S1S;
DEST_PRECISION [XFDIV_D] := S1D;
DEST_PRECISION [XFDIVV_D] := S1D;
DEST_PRECISION [XFTRANS_S_D] := S1S;
DEST_PRECISION [XFTRANS_D_S] := S1D;
DEST_PRECISION [XINC_S] := S1S;
DEST_PRECISION [XMOV_A] := S1S;
DEST_PRECISION [XMOV_Q_Q] := S1Q;
DEST_PRECISION [XMOV_Q_H] := S1Q;
DEST_PRECISION [XMOV_H_Q] := S1H;
DEST_PRECISION [XMOV_H_H] := S1H;
DEST_PRECISION [XMOV_Q_S] := S1Q;
DEST_PRECISION [XMOV_H_S] := S1H;
DEST_PRECISION [XMOV_S_Q] := S1S;
DEST_PRECISION [XMOV_S_H] := S1S;
DEST_PRECISION [XMOV_S_S] := S1S;
DEST_PRECISION [XMOV_Q_D] := S1Q;
DEST_PRECISION [XMOV_H_D] := S1H;
DEST_PRECISION [XMOV_S_D] := S1S;
DEST_PRECISION [XMOV_D_Q] := S1D;
DEST_PRECISION [XMOV_D_H] := S1D;
DEST_PRECISION [XMOV_D_S] := S1D;
DEST_PRECISION [XMOV_D_D] := S1D;
DEST_PRECISION [XMULT_S] := S1S;
DEST_PRECISION [XMULT_D] := S1D;
DEST_PRECISION [XDIV_S] := S1S; (* als/peg 18jul79 *)
DEST_PRECISION [XNEG_Q] := S1Q;
DEST_PRECISION [XNEG_H] := S1H;
DEST_PRECISION [XNEG_S] := S1S;
DEST_PRECISION [XNEG_D] := S1D;
DEST_PRECISION [XOR_Q] := S1Q;
DEST_PRECISION [XOR_D] := S1D;
DEST_PRECISION [XQUO_S] := S1S;
DEST_PRECISION [XQUOV_S] := S1S;
DEST_PRECISION [XQUO_D] := S1D;
DEST_PRECISION [XQUOV_D] := S1D;
DEST_PRECISION [XREM_S] := S1S;
DEST_PRECISION [XREMV_S] := S1S;
DEST_PRECISION [XREM_D] := S1D;
DEST_PRECISION [XREMV_D] := S1D;
DEST_PRECISION [XSHF_LF_D] := S1D;
DEST_PRECISION [XSHFV_LF_D] := S1D;
DEST_PRECISION [XSHFA_LF_S] := S1S;
DEST_PRECISION [XSHFAV_LF_S] := S1S;
DEST_PRECISION [XSUB_S] := S1S;
DEST_PRECISION [XSUBV_S] := S1S;
DEST_PRECISION [XSUB_D] := S1D;
DEST_PRECISION [XSUBV_D] := S1D;
DEST_PRECISION [XTRANS_Q_Q] := S1Q;
DEST_PRECISION [XTRANS_Q_H] := S1Q;
DEST_PRECISION [XTRANS_H_Q] := S1H;
DEST_PRECISION [XTRANS_H_H] := S1H;
DEST_PRECISION [XTRANS_Q_S] := S1Q;
DEST_PRECISION [XTRANS_H_S] := S1H;
DEST_PRECISION [XTRANS_S_Q] := S1S;
DEST_PRECISION [XTRANS_S_H] := S1S;
DEST_PRECISION [XTRANS_S_S] := S1S;
DEST_PRECISION [XTRANS_Q_D] := S1Q;
DEST_PRECISION [XTRANS_H_D] := S1H;
DEST_PRECISION [XTRANS_S_D] := S1S;
DEST_PRECISION [XTRANS_D_Q] := S1D;
DEST_PRECISION [XTRANS_D_H] := S1D;
DEST_PRECISION [XTRANS_D_S] := S1D;
DEST_PRECISION [XTRANS_D_D] := S1D;
DEST_PRECISION [XXOR_Q] := S1Q;
end (*INIT7*);
(** INITIALIZE_CLASS: **)
(**)
begin (*INITIALIZE*)
INIT1;
INIT2;
INIT3;
INIT4;
INIT5;
INIT6;
INIT7; (*PBK*)
end (*INITIALIZE*);
(** MAIN_PROGRAM: **)
(**)
begin (*Main Program.*)
ASSERTCOUNT := 0;
INITIALIZE;
(*%IFT D10*)
TIMER := CLOCK;
(*%ELSE*)
% TIMER := CLOCK(1); \
(*%ENDC*)
repeat
OLDINSTREC := NEWINSTREC;
OLDTOP := TOP;
OLDMSTTOP := MSTTOP;
READNXTINST;
if TR_UCODE then PRINTNXTINST;
ASMNXTINST;
if TR_S1CODE and (OLDINSTREC <> NEWINSTREC) then
begin
WRITELN (OUTPUT, ' Instruction(s) emitted:');
if OLDINSTREC = nil then
OLDINSTREC := MAINCODE.FIRST;
while OLDINSTREC <> nil do
begin
UNKNOWN_LOC := 0;
DISASSEMBLE (UNKNOWN_LOC, OLDINSTREC);
OLDINSTREC := OLDINSTREC↑.NEXTPTR; (*DATASTRCH*)
end;
end;
if TR_STACK then
begin
if OLDTOP < TOP then
WRITELN (OUTPUT, ' Stack pushed. New top is ',
TOP : FLDW(TOP) )
else if OLDTOP > TOP then
WRITELN (OUTPUT, ' Stack popped. New top is ',
TOP : FLDW(TOP) )
else if TOP >= BOT then
WRITELN (OUTPUT, ' Stack top is ')
else
WRITELN (OUTPUT, ' Stack is empty.');
if TOP >= BOT then PRINTDATUM (TOP);
end;
if TR_MST and (MSTTOP <> OLDMSTTOP) then
begin
if OLDMSTTOP < MSTTOP then
WRITELN (OUTPUT, ' MST stack pushed. New top is ',
MSTTOP : FLDW(MSTTOP) )
else if OLDMSTTOP > MSTTOP then
WRITELN (OUTPUT, ' MST stack popped. New top is ',
MSTTOP : FLDW(MSTTOP) );
PRINT_MSTENTRY (MSTTOP);
end;
until OPC = USTP;
if ICUPSEEN then GEN_PSWITCH;
if not ASM then (*12AUG79 EJG*)
WRITE(OUTPUT,chr(12)); (*12 dec = 14 oct = FF (form feed) *)
WRITELN (OUTPUT,'************************** ;START OF STATISTICS'); (*LCW*)
WRITELN (OUTPUT,'************************** ;WRITER-ID: ',
SOPA_ID); (*23JUL79 PTZ*)
WRITELN (OUTPUT); (*PBK*)
WRITELN (OUTPUT,' PEEPHOLE OPTIMIZER STATISTICS:'); (*PBK*)
WRITELN (OUTPUT); (*PBK*)
WRITELN (OUTPUT,' ',J_TO_J_CNT:7,' JMPAS CHAINED'); (*PBK*)
WRITELN (OUTPUT,' ',JMPAS_REMOVED_FROM_SKIPS:7,' JMPAS REMOVED FROM SKIPS');(*PTZ*)
MOVS_COLLAPSED := 0; (*31AUG79 PTZ...*)
for ICNT := 1 to 14 do
MOVS_COLLAPSED := MOVS_COLLAPSED + MOV_COLLAPSE[ICNT];
WRITELN (OUTPUT,' ',MOVS_COLLAPSED:7,' OP-MOVS COLLAPSED');
WRITE (OUTPUT,'(':10);
for ICNT := 1 to 7 do
WRITE (OUTPUT,MOV_COLLAPSE[ICNT]:7,' ');
WRITELN (OUTPUT,')');
WRITE (OUTPUT,'(':10);
for ICNT := 8 to 14 do
WRITE (OUTPUT,MOV_COLLAPSE[ICNT]:7,' ');
WRITELN (OUTPUT,')');
INC_SKPS_COLLAPSED := 0;
for ICNT := 1 to 3 do
INC_SKPS_COLLAPSED := INC_SKPS_COLLAPSED + INC_SKP_COLLAPSE[ICNT];
WRITELN (OUTPUT,' ',INC_SKPS_COLLAPSED:7,' INC-SKPS COLLAPSED');
WRITE (OUTPUT,'(':10);
for ICNT := 1 to 3 do
WRITE (OUTPUT,INC_SKP_COLLAPSE[ICNT]:7,' ');
WRITELN (OUTPUT,')'); (*...31AUG79 PTZ*)
WRITELN (OUTPUT);
WRITELN (OUTPUT,' ',INSTR_WDS_REMOVED:7,' TOTAL WORDS REMOVED'); (*PTZ*)
WRITELN (OUTPUT); (*22JUN79 PTZ*)
WRITELN (OUTPUT,' INSTRUCTION COUNTS:'); (*LCW*)
WRITELN (OUTPUT); (*LCW*)
S1OP_TOT := 0; (*LCW*)
for S1OP := FIRSTS1OP to LASTS1OP do (*LCW*)
begin (*LCW*)
if OPFORMAT[S1OP] <> VFAKEOP then (*21JUN79 PTZ*)
S1OP_TOT := S1OP_TOT + S1OP_CNT[S1OP]; (*21JUN79 PTZ*)
if S1OP_CNT[S1OP] <> 0 (*LCW*)
then WRITELN (OUTPUT,' ',S1OP_CNT[S1OP]:7,' ',S1MNEM[S1OP]); (*LCW*)
end; (*LCW*)
WRITELN (OUTPUT); (*LCW*)
WRITELN (OUTPUT,' ',S1OP_TOT:7,' TOTAL REAL INSTRUCTIONS'); (*21JUN79 PTZ*)
WRITELN (OUTPUT); (*LCW*)
WRITELN (OUTPUT,' ',WORD_CNT:7,' TXT WORDS OUTPUT TO LOADER FILE'); (*LCW*)
WRITELN (OUTPUT); (*31AUG79 PTZ...*)
WRITELN (OUTPUT,' COMPILATION STATISTICS:');
WRITELN (OUTPUT);
WRITELN (OUTPUT,' ',NUM_PROCS_COMPILED:10,' PROCEDURES COMPILED');
(*%IFT D10*)
WRITELN (OUTPUT,' ',TOTAL_STORAGE div NUM_PROCS_COMPILED:10,
' AVERAGE HEAP SPACE USED PER PROCEDURE (WORDS)');
WRITELN (OUTPUT,' ',MAX_STORAGE:10,' MAXIMUM HEAP SPACE USED (WORDS)');
(*%ELSE*)
%WRITELN (OUTPUT,' ',TOTAL_STORAGE div (NUM_PROCS_COMPILED*WORDUNITS):10, \
% ' AVERAGE HEAP SPACE USED PER PROCEDURE (WORDS)'); \
%WRITELN (OUTPUT,' ',MAX_STORAGE div WORDUNITS:10, \
% ' MAXIMUM HEAP SPACE USED (WORDS)'); \
(*%ENDC*) (*...31AUG79 PTZ*)
WRITELN(OUTPUT);
WRITE (OUTPUT, ' **** ');
if ERRORCNT > 0 then WRITE (OUTPUT, ERRORCNT : 5)
else WRITE (OUTPUT, 'NO' : 5);
WRITELN (OUTPUT, ' ASSEMBLY ERROR(S) DETECTED'); (*31AUG79 PTZ...*)
(*%IFT D10 *)
TIMER := ( CLOCK - TIMER ) div 10;
(*%ELSE*)
% TIMER := ( CLOCK(1) - TIMER ) div 10; \
(*%ENDC*)
WRITELN (OUTPUT,' **** ',TIMER div 100 : 4, '.', TIMER mod 100 : 2,
' SECONDS in U-CODE ASSEMBLY' ); (*...31AUG79 PTZ*)
if ERRORCNT <> 0 then ERREXIT (ERRORCNT);
end (*Main Program*).